diff --git a/hgeometry-combinatorial/src/HGeometry/Sequence/Alternating.hs b/hgeometry-combinatorial/src/HGeometry/Sequence/Alternating.hs index 2b802f0be..0ed46c1f8 100644 --- a/hgeometry-combinatorial/src/HGeometry/Sequence/Alternating.hs +++ b/hgeometry-combinatorial/src/HGeometry/Sequence/Alternating.hs @@ -11,6 +11,7 @@ -------------------------------------------------------------------------------- module HGeometry.Sequence.Alternating ( Alternating(..) + , fromNonEmptyWith , mapF , withNeighbours , mergeAlternating @@ -32,6 +33,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Semigroup.Traversable import GHC.Generics (Generic) +import HGeometry.Foldable.Util import Prelude hiding (reverse) -------------------------------------------------------------------------------- @@ -71,6 +73,13 @@ instance Foldable f => Bifoldable (Alternating f) where instance Traversable f => Bitraversable (Alternating f) where bitraverse f g (Alternating x xs) = Alternating <$> g x <*> traverse (bitraverse f g) xs + +-- | Given a separator, and some foldable structure, constructs an Alternating. +fromNonEmptyWith :: (HasFromFoldable g, Foldable1 f) => sep -> f a -> Alternating g sep a +fromNonEmptyWith sep xs = let (x0 :| xs') = toNonEmpty xs + in Alternating x0 $ fromList (map (sep,) xs') + + -- | map some function changing the f into a g. mapF :: (f (sep, a) -> g (sep', a)) -> Alternating f sep a -> Alternating g sep' a @@ -139,6 +148,11 @@ reverse p@(Alternating s xs) = case NonEmpty.nonEmpty xs of -- | Given a function f that takes the (current) last element x, and the new element y, -- and computes the new separating element s, snocs the separator and y onto the -- alternating list. +-- +-- >>> snocElemWith (\_ _ -> ".") (fromNonEmptyWith @[] "," (NonEmpty.fromList [1..5])) 6 +-- Alternating 1 [(",",2),(",",3),(",",4),(",",5),(".",6)] +-- >>> snocElemWith (\_ _ -> ".") (fromNonEmptyWith @[] "," (NonEmpty.fromList [1])) 6 +-- Alternating 1 [(".",6)] snocElemWith :: Snoc (f (sep,a)) (f (sep,a)) (sep,a) (sep,a) => (a -> a -> sep) -> Alternating f sep a -> a -> Alternating f sep a diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal index ce56f2350..6849b8c42 100644 --- a/hgeometry/hgeometry.cabal +++ b/hgeometry/hgeometry.cabal @@ -599,6 +599,7 @@ test-suite kernel-hspec Spec Point2Spec HGeometry.Line.PointAndVectorSpec + HGeometry.Line.GeneralSpec HGeometry.LineSegmentSpec HGeometry.BallSpec HGeometry.BoxSpec diff --git a/hgeometry/kernel/src/HGeometry/Line/General.hs b/hgeometry/kernel/src/HGeometry/Line/General.hs index cc0180a7e..03f1868e0 100644 --- a/hgeometry/kernel/src/HGeometry/Line/General.hs +++ b/hgeometry/kernel/src/HGeometry/Line/General.hs @@ -60,8 +60,8 @@ instance HyperPlane_ (VerticalOrLineEQ r) 2 r where instance (Fractional r, Eq r) => ConstructableHyperPlane_ (VerticalOrLineEQ r) 2 r where type HyperPlaneFromEquationConstraint (VerticalOrLineEQ r) 2 r = () - hyperPlaneFromEquation v@(Vector3 c _ b) - | b == 0 = VerticalLineThrough (-c) + hyperPlaneFromEquation v@(Vector3 a b c) + | b == 0 = VerticalLineThrough ((-c)/a) | otherwise = NonVertical $ hyperPlaneFromEquation v diff --git a/hgeometry/kernel/test/HGeometry/Line/GeneralSpec.hs b/hgeometry/kernel/test/HGeometry/Line/GeneralSpec.hs new file mode 100644 index 000000000..4a4cdc55f --- /dev/null +++ b/hgeometry/kernel/test/HGeometry/Line/GeneralSpec.hs @@ -0,0 +1,28 @@ +module HGeometry.Line.GeneralSpec + (spec + ) where + +import HGeometry.HyperPlane.Class +import HGeometry.Kernel.Instances () +import HGeometry.Line.General +import HGeometry.Number.Real.Rational (RealNumber) +import HGeometry.Vector +import Test.Hspec + +-------------------------------------------------------------------------------- + +type R = RealNumber 5 + +spec :: Spec +spec = do + describe "Line General Form" $ do + it "should be vertical" $ do + let l = VerticalLineThrough 5 + asGeneralLine l `shouldBe` l + it "hyperPlaneEq vertical line" $ + hyperPlaneEquation (VerticalLineThrough 5) `shouldBe` (Vector3 1 0 (-5)) + + +asGeneralLine :: HyperPlane_ hyperPlane 2 R + => hyperPlane -> VerticalOrLineEQ R +asGeneralLine = hyperPlaneFromEquation . hyperPlaneEquation diff --git a/hgeometry/src/HGeometry/HalfPlane/CommonIntersection.hs b/hgeometry/src/HGeometry/HalfPlane/CommonIntersection.hs index 20f3a5fcd..7f37f09a3 100644 --- a/hgeometry/src/HGeometry/HalfPlane/CommonIntersection.hs +++ b/hgeometry/src/HGeometry/HalfPlane/CommonIntersection.hs @@ -28,6 +28,7 @@ import HGeometry.Polygon.Convex import HGeometry.Sequence.Alternating import HGeometry.Vector +import Debug.Trace -------------------------------------------------------------------------------- -- | Common intersection of a bunch of halfplanes @@ -73,6 +74,7 @@ commonIntersection :: ( Foldable1 f, Functor f , Fractional r, Ord r , Default (LineEQ r :+ halfPlane), Default halfPlane -- FIXME + , Show halfPlane, Show r ) => f halfPlane -> CommonIntersection halfPlane r commonIntersection hs0 = case partitionEithersNE . fmap classifyHalfPlane $ toNonEmpty hs0 of @@ -132,9 +134,12 @@ lowerBoundary = undefined upperBoundary :: ( HalfPlane_ halfPlane r , Foldable1 f, Fractional r, Ord r , Default (LineEQ r :+ halfPlane), Default halfPlane -- FIXME + + , Show halfPlane, Show r ) => f halfPlane -> Chain Seq halfPlane r -upperBoundary hs0 = Chain $ case partitionEithersNE . fmap classifyHalfPlane $ toNonEmpty hs0 of +upperBoundary hs0 = Chain $ case traceShowWith ("partitioning",) $ + partitionEithersNE . fmap classifyHalfPlane $ toNonEmpty hs0 of This onlyVerticals -> let (_ :+ h) = leftMostPlane onlyVerticals in Alternating h mempty That onlyNonVerticals -> let env = view extra <$> lowerEnvelope' onlyNonVerticals @@ -143,15 +148,18 @@ upperBoundary hs0 = Chain $ case partitionEithersNE . fmap classifyHalfPlane $ t env = clipRight maxX $ lowerEnvelope' nonVerticals -- we clip the env at the leftmost vertical plane, throwing -- away any vertices whose x-coord is at most maxX - alt = snocElemWith (intersectVertical maxX) + alt = traceShowWith ("alt",env,) $ + snocElemWith (intersectVertical maxX) (env^._Alternating) - (undefined :+ h) + (dummy :+ h) -- we snoc the new element onto the alternating list. - -- we use undefined to create a dummy non-vertical + -- we create a dummy non-vertical -- line (that we will next immediately) throw away -- anyway in view extra <$> alt where + dummy = LineEQ 0 0 + classifyHalfPlane h = case h^.boundingHyperPlane.to asGeneralLine of VerticalLineThrough x -> Left (x :+ h) NonVertical l -> Right (l :+ h) diff --git a/hgeometry/test-with-ipe/test/HalfPlane/CommonIntersectionSpec.hs b/hgeometry/test-with-ipe/test/HalfPlane/CommonIntersectionSpec.hs index 1c03c9de9..3ed605c4b 100644 --- a/hgeometry/test-with-ipe/test/HalfPlane/CommonIntersectionSpec.hs +++ b/hgeometry/test-with-ipe/test/HalfPlane/CommonIntersectionSpec.hs @@ -44,12 +44,14 @@ myHalfPlanes :: NonEmpty (HalfPlane R) myHalfPlanes = NonEmpty.fromList [ below $ LineEQ 1 1 , below $ LineEQ (-1) 2 + , leftOf $ 10 ] theAnswer :: CommonIntersection (HalfPlane R) R theAnswer = Unbounded . Chain $ Alternating (myHalfPlanes NonEmpty.!! 0) (Seq.fromList $ [ (Point2 (1/2) (3/2), myHalfPlanes NonEmpty.!! 1) + , (Point2 10 (-8), myHalfPlanes NonEmpty.!! 2) ] )