diff --git a/Graphics/Slicer/Machine/Infill.hs b/Graphics/Slicer/Machine/Infill.hs index f06d025c0..a0e13099c 100644 --- a/Graphics/Slicer/Machine/Infill.hs +++ b/Graphics/Slicer/Machine/Infill.hs @@ -22,7 +22,8 @@ module Graphics.Slicer.Machine.Infill (makeInfill, makeSupport) where -import Prelude ((+), (<$>), ($), maximum, minimum, filter, (>), head, (.), flip, (*), sqrt, (-), (<>), show, error, otherwise, (&&), (==), length, (<), concat, not, null, (!!), fmap, (||)) +import Prelude ((+), (<$>), ($), head, filter, (>), (.), flip, (*), sqrt, (-), (<>), show, error, otherwise, (&&), (==), length, (<), concat, not, null, (!!), fmap, (||)) +import Safe (headNote, maximumNote, minimumNote) import Data.Maybe (Maybe(Just, Nothing), catMaybes, mapMaybe, fromMaybe) @@ -90,10 +91,10 @@ coveringLinesNegative :: Contour -> ℝ -> ℝ -> [Line] coveringLinesNegative (Contour contourPoints) ls zHeight = flip Line s . f <$> [-xMin,-xMin+lsX..xMax] where s = Point (xMaxOutside,yMaxOutside,0) f v = Point (v,0,zHeight) - xMinRaw = minimum $ xOf <$> contourPoints - xMin = head $ filter (> xMinRaw) [0,ls..] - xMax = maximum $ xOf <$> contourPoints - yMax = maximum $ yOf <$> contourPoints + xMinRaw = minimumNote "convergingLinesNegative xMinRaw" $ xOf <$> contourPoints + xMin = headNote "convergingLinesNegative xMin" $ filter (> xMinRaw) [0,ls..] + xMax = maximumNote "convergingLinesNegative x" $ xOf <$> contourPoints + yMax = maximumNote "convergingLinesNegative y" $ yOf <$> contourPoints xMaxOutside = xMax + ls yMaxOutside = yMax + ls lsX = sqrt $ ls*ls+ls*ls @@ -107,10 +108,10 @@ coveringLinesPositive :: Contour -> ℝ -> ℝ -> [Line] coveringLinesPositive (Contour contourPoints) ls zHeight = flip Line s . f <$> [0,lsY..yMax + xMax] where s = Point (xMaxOutside + yMaxOutside,- xMaxOutside - yMaxOutside,0) f v = Point (0,v,zHeight) - yMinRaw = minimum $ yOf <$> contourPoints - yMin = head $ filter (> yMinRaw) [0,ls..] - yMax = maximum $ yOf <$> contourPoints - xMax = maximum $ xOf <$> contourPoints + yMinRaw = minimumNote "convergingLinesPositive yMinRaw" $ yOf <$> contourPoints + yMin = headNote "convergingLinesPositive yMin" $ filter (> yMinRaw) [0,ls..] + yMax = maximumNote "convergingLinesPositive y" $ yOf <$> contourPoints + xMax = maximumNote "convergingLinesPositive x" $ xOf <$> contourPoints xMaxOutside = xMax + ls yMaxOutside = yMax + ls lsY = sqrt $ ls*ls+ls*ls @@ -124,10 +125,10 @@ coveringLinesVertical :: Contour -> ℝ -> ℝ -> [Line] coveringLinesVertical (Contour contourPoints) ls zHeight = flip Line s . f <$> [xMin,xMin+ls..xMax] where s = Point (0,yMaxOutside,0) f v = Point (v,0,zHeight) - xMinRaw = minimum $ xOf <$> contourPoints - xMin = head $ filter (> xMinRaw) [0,ls..] - xMax = maximum $ xOf <$> contourPoints - yMax = maximum $ yOf <$> contourPoints + xMinRaw = minimumNote "convergingLinesVertical xMin" $ xOf <$> contourPoints + xMin = headNote "convergingLinesVertical xMin"$ filter (> xMinRaw) [0,ls..] + xMax = maximumNote "convergingLinesVertical x" $ xOf <$> contourPoints + yMax = maximumNote "convergingLinesVertical y" $ yOf <$> contourPoints yMaxOutside = yMax + ls xOf, yOf :: Point -> ℝ xOf (Point (x,_,_)) = x @@ -139,10 +140,10 @@ coveringLinesHorizontal :: Contour -> ℝ -> ℝ -> [Line] coveringLinesHorizontal (Contour contourPoints) ls zHeight = flip Line s . f <$> [yMin,yMin+ls..yMax] where s = Point (xMaxOutside,0,0) f v = Point (0,v,zHeight) - yMinRaw = minimum $ yOf <$> contourPoints - yMin = head $ filter (> yMinRaw) [0,ls..] - yMax = maximum $ yOf <$> contourPoints - xMax = maximum $ xOf <$> contourPoints + yMinRaw = minimumNote "convergingLinesHorizontal yMinRaw" $ yOf <$> contourPoints + yMin = headNote "convergingLinesHorizontal yMin" $ filter (> yMinRaw) [0,ls..] + yMax = maximumNote "convergingLinesHorizontal y" $ yOf <$> contourPoints + xMax = maximumNote "convergingLinesHorizontal x" $ xOf <$> contourPoints xMaxOutside = xMax + ls xOf, yOf :: Point -> ℝ xOf (Point (x,_,_)) = x @@ -178,10 +179,10 @@ boundingBoxAll :: [Contour] -> Maybe BBox boundingBoxAll contours = if isEmptyBBox box then Nothing else Just box where box = BBox (minX, minY) (maxX, maxY) - minX = minimum $ (\(BBox (x1,_) _) -> x1) <$> bBoxes - minY = minimum $ (\(BBox (_,y1) _) -> y1) <$> bBoxes - maxX = maximum $ (\(BBox _ (x2,_)) -> x2) <$> bBoxes - maxY = maximum $ (\(BBox _ (_,y2)) -> y2) <$> bBoxes + minX = minimumNote "boundingBoxAll" $ (\(BBox (x1,_) _) -> x1) <$> bBoxes + minY = minimumNote "boundingBoxAll" $ (\(BBox (_,y1) _) -> y1) <$> bBoxes + maxX = maximumNote "boundingBoxAll" $ (\(BBox _ (x2,_)) -> x2) <$> bBoxes + maxY = maximumNote "boundingBoxAll" $ (\(BBox _ (_,y2)) -> y2) <$> bBoxes bBoxes = mapMaybe boundingBox contours -- Get a 2D bounding box of a 2D contour. @@ -190,10 +191,10 @@ boundingBox (Contour []) = Nothing boundingBox (Contour contourPoints) = if isEmptyBBox box then Nothing else Just box where box = BBox (minX, minY) (maxX, maxY) - minX = minimum $ xOf <$> contourPoints - minY = minimum $ yOf <$> contourPoints - maxX = maximum $ xOf <$> contourPoints - maxY = maximum $ yOf <$> contourPoints + minX = minimumNote "boundingBox" $ xOf <$> contourPoints + minY = minimumNote "boundingBox" $ yOf <$> contourPoints + maxX = maximumNote "boundingBox" $ xOf <$> contourPoints + maxY = maximumNote "boundingBox" $ yOf <$> contourPoints xOf,yOf :: Point -> ℝ xOf (Point (x,_,_)) = x yOf (Point (_,y,_)) = y diff --git a/Graphics/Slicer/Math/Contour.hs b/Graphics/Slicer/Math/Contour.hs index ec6b2aa2f..5a8f9e352 100644 --- a/Graphics/Slicer/Math/Contour.hs +++ b/Graphics/Slicer/Math/Contour.hs @@ -21,7 +21,8 @@ module Graphics.Slicer.Math.Contour (getContours, makeContourTree, innerPerimeterPoint, outerPerimeterPoint, lineToOutsideContour, ContourTree(ContourTree), lineEntersContour) where -import Prelude ((==), otherwise, (++), (||), (.), null, (<$>), ($), (>), length, Show, filter, (/=), odd, snd, error, (<>), show, fst, (*), Bool, (-), (<), pi, (&&), sqrt, (+), (<*>), minimum, maximum) +import Prelude ((==), otherwise, (++), (||), (.), null, (<$>), ($), (>), length, Show, filter, (/=), odd, snd, error, (<>), show, fst, (*), Bool, (-), (<), pi, (&&), sqrt, (+), (<*>)) +import Safe (maximumNote, minimumNote, headNote, lastNote) import Data.List(find, delete, tail, last, head, init, zipWith, nub) @@ -52,7 +53,7 @@ makeContours :: ([[Point]], [[Point]]) -> [[Point]] makeContours (contours, pairs) | null pairs = contours | otherwise = makeContours (contours ++ [next], ps) - where (next, ps) = findContour (head pairs, tail pairs) + where (next, ps) = findContour (headNote "makeContours" pairs, tail pairs) -- FIXME: square is double loop? -- NOTE: drop contours with less than 3 points. @@ -72,7 +73,7 @@ getContours pointPairs = Contour <$> (filteredContourSets foundContourSets) -- | Given a line, generate a pair of lines from points on both sides of the given line's midpoint to the origin, on the same z plane as the given line. perimeterLinesToCheck :: ℝ -> Line -> (Line, Line) -perimeterLinesToCheck pathWidth l@(Line p _) = (head linePair, last linePair) +perimeterLinesToCheck pathWidth l@(Line p _) = (headNote "perimeterLinesToCheck" linePair, lastNote "perimeterLinesToCheck" linePair) where linePair = (`lineFromEndpoints` Point (0,0,zOf p)) . endpoint . pointSlopeLength (midpoint l) (lineSlope m) . (*pathWidth) <$> [-1,1] Line _ m = perpendicularBisector l @@ -109,8 +110,8 @@ innerPerimeterPoint pathWidth contour l -- | Find an exterior point on the perpendicular bisector of the given line, pathWidth from the line. outerPerimeterPoint :: ℝ -> Contour -> Line -> Point outerPerimeterPoint pathWidth contour l - | (snd $ head intersections) == innerPoint = snd $ last intersections - | otherwise = snd $ head intersections + | (snd $ headNote "outerPerimeterPoint" intersections) == innerPoint = snd $ lastNote "outerPerimeterPoint" intersections + | otherwise = snd $ headNote "outerPerimeterPoint #2" intersections where linesToCheck = perimeterLinesToCheck pathWidth l bothLinesToCheck = fst linesToCheck : [snd linesToCheck] @@ -129,7 +130,7 @@ outerPerimeterPoint pathWidth contour l -- | Given a point and slope (on an xy plane), make a line segment, where the far end is guaranteed to be outside the contour. lineToOutsideContour :: Contour -> ℝ -> Slope -> Point -> Line -lineToOutsideContour (Contour contourPoints) outsideDistance m p@(Point (_,_,z)) = head . makeLines . nub $ (roundPoint <$> points) +lineToOutsideContour (Contour contourPoints) outsideDistance m p@(Point (_,_,z)) = headNote "lineToOutsideContour" . makeLines . nub $ (roundPoint <$> points) where longestLength = sqrt $ dx*dx + dy*dy halfLine@(Line p' s) = pointSlopeLength p m longestLength -- should have p' == p @@ -142,10 +143,10 @@ lineToOutsideContour (Contour contourPoints) outsideDistance m p@(Point (_,_,z)) saneIntersection res = error $ "insane result drawing a line to the edge: " <> show res <> "\n" edges = lineFromEndpoints <$> [Point (xMin,yMin,z), Point (xMax,yMax,z)] <*> [Point (xMin,yMax,z), Point (xMax,yMin,z)] - xMinRaw = minimum $ xOf <$> contourPoints - yMinRaw = minimum $ yOf <$> contourPoints - xMaxRaw = maximum $ xOf <$> contourPoints - yMaxRaw = maximum $ yOf <$> contourPoints + xMinRaw = minimumNote "lineToOutsideContour x" $ xOf <$> contourPoints + yMinRaw = minimumNote "lineToOutsideContour y" $ yOf <$> contourPoints + xMaxRaw = maximumNote "lineToOutsideContour x" $ xOf <$> contourPoints + yMaxRaw = maximumNote "lineToOutsideContour y" $ yOf <$> contourPoints (dx,dy) = (xMax-xMin, yMax-yMin) xMin = xMinRaw - outsideDistance yMin = yMinRaw - outsideDistance @@ -183,7 +184,7 @@ contourContainsContour parent child = if odd noIntersections then Just child els saneIntersection res = error $ "insane result determining whether a contour contains a contour: " <> show res <> "\n" innerPointOf contour = innerPerimeterPoint 0.0001 contour $ oneLineOf contour where - oneLineOf (Contour contourPoints) = head $ makeLines contourPoints + oneLineOf (Contour contourPoints) = headNote "contourContainsContour" $ makeLines contourPoints -- determine whether a contour is inside of another contour. contourContainedByContour :: Contour -> Contour -> Maybe Contour @@ -200,7 +201,7 @@ contourContainedByContour child parent = if odd noIntersections then Just child saneIntersection res = error $ "insane result determining whether a contour is contained by a contour: " <> show res <> "\n" innerPointOf contour = innerPerimeterPoint 0.0001 contour $ oneLineOf contour where - oneLineOf (Contour contourPoints) = head $ makeLines contourPoints + oneLineOf (Contour contourPoints) = headNote "contourContainedByContour" $ makeLines contourPoints -- Does a given line, in the direction it is given, enter from outside of a contour to inside of a contour, through a given point? -- Used to check the corner case of corner cases. @@ -221,5 +222,5 @@ lineEntersContour (Line _ m) intersection contour@(Contour contourPoints) = line -- lineTo has an endpoint of the intersection, lineFrom has a starting point of the intersection. (lineTo, lineFrom) = findLinesInContour intersection contourLines = makeLinesLooped contourPoints - findLinesInContour (HitEndpointL2 pt) = head $ catMaybes $ zipWith (\l1@(Line _ _) l2@(Line p2 _) -> if p2 == pt then Just (l1,l2) else Nothing) (init contourLines) (tail contourLines) + findLinesInContour (HitEndpointL2 pt) = headNote "lineEntersContour" $ catMaybes $ zipWith (\l1@(Line _ _) l2@(Line p2 _) -> if p2 == pt then Just (l1,l2) else Nothing) (init contourLines) (tail contourLines) findLinesInContour other = error $ "trying to find where a line enters a contour on something not a point of a contour where two lines intersect: " <> show other <> "\n" diff --git a/hslice.cabal b/hslice.cabal index 6b8535e9f..164ba8ac4 100644 --- a/hslice.cabal +++ b/hslice.cabal @@ -22,6 +22,7 @@ Library implicit, mtl, parallel, + safe, utf8-string Ghc-options: -optc-O3 @@ -67,6 +68,7 @@ Executable extcuraengine optparse-applicative, parallel, text, + safe, utf8-string Ghc-options: -threaded diff --git a/programs/extcuraengine.hs b/programs/extcuraengine.hs index e6908e279..154456c21 100644 --- a/programs/extcuraengine.hs +++ b/programs/extcuraengine.hs @@ -41,7 +41,8 @@ import Data.String (String) import Data.Bool(Bool(True, False), otherwise, not) -import Data.List (length, zip, tail, head, zipWith, maximum, minimum, last, (++), concat, null) +import Data.List (length, zip, tail, head, zipWith, last, (++), concat, null) +import Safe (minimumNote, maximumNote) import Control.Monad ((>>=)) @@ -104,11 +105,11 @@ centeredFacetsFromSTL (RectArea (bedX,bedY,_)) stl = shiftedFacets shiftedFacets = [shiftFacet centerPoint facet | facet <- facets] `using` parListChunk (div (length facets) (fromFastℕ threads)) rseq facets = facetLinesFromSTL threads stl (dx,dy,dz) = (bedX/2-x0, bedY/2-y0, -zMin) - xMin = minimum $ xOf.point <$> foldMap sides facets - yMin = minimum $ yOf.point <$> foldMap sides facets - zMin = minimum $ zOf.point <$> foldMap sides facets - xMax = maximum $ xOf.point <$> foldMap sides facets - yMax = maximum $ yOf.point <$> foldMap sides facets + xMin = minimumNote "centeredFacetsFromSTL xMin" $ xOf.point <$> foldMap sides facets + yMin = minimumNote "centeredFacetsFromSTL yMin" $ yOf.point <$> foldMap sides facets + zMin = minimumNote "centeredFacetsFromSTL zMin" $ zOf.point <$> foldMap sides facets + xMax = maximumNote "centeredFacetsFromSTL xMax" $ xOf.point <$> foldMap sides facets + yMax = maximumNote "centeredFacetsFromSTL yMax" $ yOf.point <$> foldMap sides facets (x0,y0) = ((xMax+xMin)/2-xMin, (yMax+yMin)/2-yMin) xOf, yOf, zOf :: Point -> ℝ xOf (Point (x,_,_)) = x @@ -128,7 +129,7 @@ layers print fs = catMaybes <$> rawContours allIntersections zLayer = catMaybes $ facetIntersects zLayer <$> fs zs = [zOf $ point triPoints | triPoints <- foldMap sides fs ] `using` parListChunk (div (length fs) (fromFastℕ threads)) rseq zmax :: ℝ - zmax = maximum zs + zmax = maximumNote "layers zmax" zs lh = layerHeight print zOf :: Point -> ℝ zOf (Point (_,_,z)) = z