hgeometry-0.9.0.0: src/Data/Geometry/LineSegment.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Geometry.LineSegment
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
--
-- Line segment data type and some basic functions on line segments
--
--------------------------------------------------------------------------------
module Data.Geometry.LineSegment( LineSegment
, pattern LineSegment
, pattern LineSegment'
, pattern ClosedLineSegment
, endPoints
, _SubLine
, module Data.Geometry.Interval
, toLineSegment
, onSegment
, orderedEndPoints
, segmentLength
, sqDistanceToSeg, sqDistanceToSegArg
, flipSegment
) where
import Control.Arrow ((&&&))
import Control.DeepSeq
import Control.Lens
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.Box.Internal
import Data.Geometry.Interval hiding (width, midPoint)
import Data.Geometry.Line.Internal
import Data.Geometry.Point
import Data.Geometry.Properties
import Data.Geometry.SubLine
import Data.Geometry.Transformation
import Data.Geometry.Vector
import Data.Ord (comparing)
import Data.Vinyl
import Data.Vinyl.CoRec
import GHC.TypeLits
import Test.QuickCheck
--------------------------------------------------------------------------------
-- * d-dimensional LineSegments
-- | Line segments. LineSegments have a start and end point, both of which may
-- contain additional data of type p. We can think of a Line-Segment being defined as
--
--
-- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p))
newtype LineSegment d p r = GLineSegment { _unLineSeg :: Interval p (Point d r)}
makeLenses ''LineSegment
-- | Pattern that essentially models the line segment as a:
--
-- >>> data LineSegment d p r = LineSegment (EndPoint (Point d r :+ p)) (EndPoint (Point d r :+ p))
pattern LineSegment :: EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p)
-> LineSegment d p r
pattern LineSegment s t = GLineSegment (Interval s t)
{-# COMPLETE LineSegment #-}
-- | Gets the start and end point, but forgetting if they are open or closed.
pattern LineSegment' :: Point d r :+ p
-> Point d r :+ p
-> LineSegment d p r
pattern LineSegment' s t <- ((^.start) &&& (^.end) -> (s,t))
{-# COMPLETE LineSegment' #-}
pattern ClosedLineSegment :: Point d r :+ p
-> Point d r :+ p
-> LineSegment d p r
pattern ClosedLineSegment s t = GLineSegment (ClosedInterval s t)
{-# COMPLETE ClosedLineSegment #-}
type instance Dimension (LineSegment d p r) = d
type instance NumType (LineSegment d p r) = r
instance HasStart (LineSegment d p r) where
type StartCore (LineSegment d p r) = Point d r
type StartExtra (LineSegment d p r) = p
start = unLineSeg.start
instance HasEnd (LineSegment d p r) where
type EndCore (LineSegment d p r) = Point d r
type EndExtra (LineSegment d p r) = p
end = unLineSeg.end
instance (Arbitrary r, Arbitrary p, Arity d) => Arbitrary (LineSegment d p r) where
arbitrary = LineSegment <$> arbitrary <*> arbitrary
deriving instance (Arity d, NFData r, NFData p) => NFData (LineSegment d p r)
-- | Traversal to access the endpoints. Note that this traversal
-- allows you to change more or less everything, even the dimension
-- and the numeric type used, but it preservers if the segment is open
-- or closed.
endPoints :: Traversal (LineSegment d p r) (LineSegment d' q s)
(Point d r :+ p) (Point d' s :+ q)
endPoints = \f (LineSegment p q) -> LineSegment <$> traverse f p
<*> traverse f q
_SubLine :: (Num r, Arity d) => Iso' (LineSegment d p r) (SubLine d p r r)
_SubLine = iso segment2SubLine subLineToSegment
{-# INLINE _SubLine #-}
segment2SubLine :: (Num r, Arity d)
=> LineSegment d p r -> SubLine d p r r
segment2SubLine ss = SubLine (Line p (q .-. p)) (Interval s e)
where
p = ss^.start.core
q = ss^.end.core
(Interval a b) = ss^.unLineSeg
s = a&unEndPoint.core .~ 0
e = b&unEndPoint.core .~ 1
subLineToSegment :: (Num r, Arity d) => SubLine d p r r -> LineSegment d p r
subLineToSegment sl = let (Interval s' e') = (fixEndPoints sl)^.subRange
s = s'&unEndPoint %~ (^.extra)
e = e'&unEndPoint %~ (^.extra)
in LineSegment s e
instance (Num r, Arity d) => HasSupportingLine (LineSegment d p r) where
supportingLine s = lineThrough (s^.start.core) (s^.end.core)
instance (Show r, Show p, Arity d) => Show (LineSegment d p r) where
show ~(LineSegment p q) = concat ["LineSegment (", show p, ") (", show q, ")"]
deriving instance (Eq r, Eq p, Arity d) => Eq (LineSegment d p r)
-- deriving instance (Ord r, Ord p, Arity d) => Ord (LineSegment d p r)
deriving instance Arity d => Functor (LineSegment d p)
instance PointFunctor (LineSegment d p) where
pmap f ~(LineSegment s e) = LineSegment (s&unEndPoint.core %~ f)
(e&unEndPoint.core %~ f)
instance Arity d => IsBoxable (LineSegment d p r) where
boundingBox l = boundingBox (l^.start.core) <> boundingBox (l^.end.core)
instance (Fractional r, Arity d, Arity (d + 1)) => IsTransformable (LineSegment d p r) where
transformBy = transformPointFunctor
instance Arity d => Bifunctor (LineSegment d) where
bimap f g (GLineSegment i) = GLineSegment $ bimap f (fmap g) i
-- ** Converting between Lines and LineSegments
-- | Directly convert a line into a line segment.
toLineSegment :: (Monoid p, Num r, Arity d) => Line d r -> LineSegment d p r
toLineSegment (Line p v) = ClosedLineSegment (p :+ mempty)
(p .+^ v :+ mempty)
-- *** Intersecting LineSegments
type instance IntersectionOf (LineSegment 2 p r) (LineSegment 2 p r) = [ NoIntersection
, Point 2 r
, LineSegment 2 p r
]
type instance IntersectionOf (LineSegment 2 p r) (Line 2 r) = [ NoIntersection
, Point 2 r
, LineSegment 2 p r
]
instance (Ord r, Fractional r) =>
(LineSegment 2 p r) `IsIntersectableWith` (LineSegment 2 p r) where
nonEmptyIntersection = defaultNonEmptyIntersection
a `intersect` b = match ((a^._SubLine) `intersect` (b^._SubLine)) $
(H coRec)
:& (H coRec)
:& (H $ coRec . subLineToSegment)
:& RNil
instance (Ord r, Fractional r) =>
(LineSegment 2 p r) `IsIntersectableWith` (Line 2 r) where
nonEmptyIntersection = defaultNonEmptyIntersection
s `intersect` l = let ubSL = s^._SubLine.re _unBounded.to dropExtra
in match (ubSL `intersect` (fromLine l)) $
(H coRec)
:& (H $ coRec)
:& (H $ const (coRec s))
:& RNil
-- * Functions on LineSegments
-- | Test if a point lies on a line segment.
--
-- >>> (point2 1 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ()))
-- True
-- >>> (point2 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ()))
-- False
-- >>> (point2 5 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ()))
-- False
-- >>> (point2 (-1) 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ()))
-- False
-- >>> (point2 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 3 3 :+ ()))
-- True
--
-- Note that the segments are assumed to be closed. So the end points lie on the segment.
--
-- >>> (point2 2 0) `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ()))
-- True
-- >>> origin `onSegment` (ClosedLineSegment (origin :+ ()) (point2 2 0 :+ ()))
-- True
--
--
-- This function works for arbitrary dimensons.
--
-- >>> (point3 1 1 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point3 3 3 3 :+ ()))
-- True
-- >>> (point3 1 2 1) `onSegment` (ClosedLineSegment (origin :+ ()) (point3 3 3 3 :+ ()))
-- False
onSegment :: (Ord r, Fractional r, Arity d)
=> Point d r -> LineSegment d p r -> Bool
p `onSegment` l = let s = l^.start.core
t = l^.end.core
inRange' x = 0 <= x && x <= 1
in
if s == t -- zero length segment
then p == s
else maybe False inRange' $ scalarMultiple (p .-. s) (t .-. s)
-- | The left and right end point (or left below right if they have equal x-coords)
orderedEndPoints :: Ord r => LineSegment 2 p r -> (Point 2 r :+ p, Point 2 r :+ p)
orderedEndPoints s = if pc <= qc then (p, q) else (q,p)
where
p@(pc :+ _) = s^.start
q@(qc :+ _) = s^.end
-- | Length of the line segment
segmentLength :: (Arity d, Floating r) => LineSegment d p r -> r
segmentLength ~(LineSegment' p q) = distanceA (p^.core) (q^.core)
-- | Squared distance from the point to the Segment s. The same remark as for
-- the 'sqDistanceToSegArg' applies here.
sqDistanceToSeg :: (Arity d, Fractional r, Ord r) => Point d r -> LineSegment d p r -> r
sqDistanceToSeg p = fst . sqDistanceToSegArg p
-- | Squared distance from the point to the Segment s, and the point on s
-- realizing it. Note that if the segment is *open*, the closest point
-- returned may be one of the (open) end points, even though technically the
-- end point does not lie on the segment. (The true closest point then lies
-- arbitrarily close to the end point).
sqDistanceToSegArg :: (Arity d, Fractional r, Ord r)
=> Point d r -> LineSegment d p r -> (r, Point d r)
sqDistanceToSegArg p s = let m = sqDistanceToArg p (supportingLine s)
xs = m : map (\(q :+ _) -> (qdA p q, q)) [s^.start, s^.end]
in F.minimumBy (comparing fst)
. filter (flip onSegment s . snd) $ xs
-- | flips the start and end point of the segment
flipSegment :: LineSegment d p r -> LineSegment d p r
flipSegment s = let p = s^.start
q = s^.end
in (s&start .~ q)&end .~ p
-- testSeg :: LineSegment 2 () Rational
-- testSeg = LineSegment (Open $ ext origin) (Closed $ ext (point2 10 0))
-- horL' :: Line 2 Rational
-- horL' = horizontalLine 0
-- testI = testSeg `intersect` horL'
-- ff = bimap (fmap Val) (const ())
-- ss' = let (LineSegment p q) = testSeg in
-- LineSegment (p&unEndPoint %~ ff)
-- (q&unEndPoint %~ ff)
-- ss'' = ss'^._SubLine