diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml index 42d4f9564..cb2c19dc3 100644 --- a/.github/workflows/gh-pages.yml +++ b/.github/workflows/gh-pages.yml @@ -171,7 +171,7 @@ jobs: - name: haddock run: | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all > haddock.raw.txt - $CABAL haddock-project --with-compiler=$HC --with-haddock $HADDOCK + $CABAL haddock-project --with-haddock=$HADDOCK --with-ghc=$HC - name: haddock-badge run: | grep ") in " haddock.raw.txt | sort -hr > haddock.txt diff --git a/hgeometry-examples/convexHull/Main.hs b/hgeometry-examples/convexHull/Main.hs index c1009ec9d..b5b6498e0 100644 --- a/hgeometry-examples/convexHull/Main.hs +++ b/hgeometry-examples/convexHull/Main.hs @@ -16,10 +16,9 @@ import qualified HGeometry.Miso.Svg.Canvas as Canvas import HGeometry.Number.Real.Rational import HGeometry.Point import HGeometry.Polygon.Convex -import HGeometry.Polygon.Simple import qualified Language.Javascript.JSaddle.Warp as JSaddle import Miso -import Miso.String (ToMisoString(..), ms) +import Miso.String (MisoString,ToMisoString(..), ms) import Miso.Svg hiding (height_, id_, style_, width_) -------------------------------------------------------------------------------- diff --git a/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs b/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs index bacd7c8c3..58c18a754 100644 --- a/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs +++ b/hgeometry/kernel/src/HGeometry/LineSegment/Intersection.hs @@ -62,41 +62,6 @@ instance ( Point_ point 2 r, Num r, Ord r intersects = intersectsImpl {-# INLINE intersects #-} - --- instance ( Point_ point 2 r, Num r, Ord r --- ) => LinePV 2 r `HasIntersectionWith` ClosedLineSegment point where --- intersects = intersectsImpl --- {-# INLINE intersects #-} - --- instance ( Point_ point 2 r, Num r, Ord r --- ) => LineEQ r `HasIntersectionWith` ClosedLineSegment point where --- -- --- -- >>> LineEQ 1 2 `intersects` ClosedLineSegment origin (Point2 1 10) --- -- True --- intersects = intersectsImpl --- {-# INLINE intersects #-} - --- instance ( Point_ point 2 r, Num r, Ord r --- ) => LineEQ r `HasIntersectionWith` LineSegment AnEndPoint point where --- intersects = intersectsImpl --- {-# INLINE intersects #-} --- instance ( Point_ point 2 r, Num r, Ord r --- ) => LinePV 2 r `HasIntersectionWith` LineSegment AnEndPoint point where --- intersects = intersectsImpl --- {-# INLINE intersects #-} - --- instance ( Point_ point 2 r, Num r, Ord r --- ) => LinePV 2 r `HasIntersectionWith` OpenLineSegment point where --- intersects = intersectsImpl --- {-# INLINE intersects #-} - --- instance ( Point_ point 2 r, Num r, Ord r --- ) => LineEQ r `HasIntersectionWith` OpenLineSegment point where --- intersects = intersectsImpl --- {-# INLINE intersects #-} - - - -- | Test whether a line in R^2 intersects a closed linesegment intersectsImpl :: ( HyperPlane_ line 2 r , Point_ point 2 r @@ -112,9 +77,6 @@ l `intersectsImpl` s = case (onSideTest (s^.start) l, onSideTest (s^.end) l) of (GT, LT) -> True (GT, EQ) -> s^.endPoint.to endPointType == Closed (GT, GT) -> False - -- case onSideTest (s^.start) l of - -- EQ -> True - -- side -> side /= onSideTest (s^.end) l {-# INLINE intersectsImpl #-} @@ -221,8 +183,7 @@ instance ( Point_ point 2 r, Num r, Ord r LineSegment endPoint point `HasIntersectionWith` LineSegment endPoint point where s `intersects `s' = supportingLine s `intersects` s' && supportingLine s' `intersects` s {-# INLINE intersects #-} - --- TODO: specialize instance for ClosedLineSegment and AnLineSegment + -- this does not really work; i.e. if the segments are colinear instance ( Point_ point 2 r, Num r, Ord r ) => diff --git a/hgeometry/kernel/test/HGeometry/HyperPlaneSpec.hs b/hgeometry/kernel/test/HGeometry/HyperPlaneSpec.hs index 50c4e87e6..0284da995 100644 --- a/hgeometry/kernel/test/HGeometry/HyperPlaneSpec.hs +++ b/hgeometry/kernel/test/HGeometry/HyperPlaneSpec.hs @@ -145,11 +145,6 @@ spec = describe "HyperPlane Tests" $ do it "on side of non-vertical line / hyperplane 5" $ (Point2 0 0 `onSideTest` HyperPlane2 (-1) (-1) (-1)) `shouldBe` GT - - it "on vertical line" $ - ((Point 0 10) `onSideTest` (HyperPlane2 0 0 1)) - `shouldBe` EQ - prop "pointOn produces a point on the hyperplane (2d)" $ \(h :: HyperPlane 2 R) -> onHyperPlane (pointOn h) h prop "pointOn produces a point on the hyperplane (3d)" $ diff --git a/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs b/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs index a9a4d0d14..aee1601a1 100644 --- a/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs +++ b/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs @@ -205,6 +205,9 @@ test5 = OpenLineSegment (Point2 0 20) (Point2 200 20) -- -- test = withRank (Vector2 0 1) test1 test4 +vertSeg :: OpenLineSegment (Point 2 Int) +vertSeg = OpenLineSegment (Point2 20 (-5)) (Point2 20 10) + testI :: Spec testI = describe "some manual intersection tests" $ do it "manual intersection" $ (test1 `intersects` test2 ) `shouldBe` True @@ -213,6 +216,15 @@ testI = describe "some manual intersection tests" $ do it "manual intersection" $ (test2 `intersects` test4 ) `shouldBe` True it "manual intersection" $ (test2 `intersects` test5 ) `shouldBe` False + it "open ended segments x vertical Line" $ + (supportingLine vertSeg `intersects` test2) `shouldBe` False + + it "open ended segments; open endpoint on segment" $ + (test2 `intersects` vertSeg) `shouldBe` False + it "open ended segments; endpointtest" $ + (Point2 20 (0 :: Int) `onSegment` test2) `shouldBe` False + + describe "manual intersect with line" $ do let l = LinePV origin (Vector2 0 (1 :: Int)) it "man" $ (l `intersects` test1) `shouldBe` True diff --git a/hgeometry/svg/src/Miso/String/Util.hs b/hgeometry/svg/src/Miso/String/Util.hs index 60434c7d7..f0e534470 100644 --- a/hgeometry/svg/src/Miso/String/Util.hs +++ b/hgeometry/svg/src/Miso/String/Util.hs @@ -2,7 +2,8 @@ module Miso.String.Util where import qualified Data.List as List -import Miso.String (MisoString, ToMisoString, ms) +import Miso.String (MisoString) +-- | Unwords for MisoStrings unwords :: [MisoString] -> MisoString unwords = mconcat @MisoString . List.intersperse " "