hgeometry-0.14: src/Data/Geometry/SubLine.hs
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Geometry.SubLine
-- Copyright : (C) Frank Staals
-- License : see the LICENSE file
-- Maintainer : Frank Staals
--
-- SubLine; a part of a line
--
--------------------------------------------------------------------------------
module Data.Geometry.SubLine
( SubLine(..)
, line
, subRange
, fixEndPoints
, dropExtra
, onSubLine
, onSubLineUB
, onSubLine2
, onSubLine2UB
, reorient
, getEndPointsUnBounded
, fromLine
, _unBounded
, toUnbounded
, fromUnbounded
) where
import Control.Lens
import Data.Bifunctor
import Data.Ext
import qualified Data.Foldable as F
import Data.Geometry.Interval
import Data.Geometry.Line.Internal
import Data.Geometry.Point
import Data.Geometry.Properties
import Data.Geometry.Vector
import qualified Data.Traversable as T
import Data.UnBounded
import Data.Vinyl
import Data.Vinyl.CoRec
import Test.QuickCheck(Arbitrary(..))
--------------------------------------------------------------------------------
-- | Part of a line. The interval is ranged based on the vector of the
-- line l, and s.t.t zero is the anchorPoint of l.
data SubLine d p s r = SubLine { _line :: Line d r
, _subRange :: Interval p s
}
-- | Line part of SubLine.
line :: Lens (SubLine d1 p s r1) (SubLine d2 p s r2) (Line d1 r1) (Line d2 r2)
line = lens _line (\sub l -> SubLine l (_subRange sub))
-- | Interval part of SubLine.
subRange :: Lens (SubLine d p1 s1 r) (SubLine d p2 s2 r) (Interval p1 s1) (Interval p2 s2)
subRange = lens _subRange (SubLine . _line)
type instance Dimension (SubLine d p s r) = d
deriving instance (Show r, Show s, Show p, Arity d) => Show (SubLine d p s r)
-- deriving instance (Read r, Read p, Arity d) => Read (SubLine d p r)
deriving instance (Eq r, Eq s, Fractional r, Eq p, Arity d) => Eq (SubLine d p s r)
deriving instance Arity d => Functor (SubLine d p s)
deriving instance Arity d => F.Foldable (SubLine d p s)
deriving instance Arity d => T.Traversable (SubLine d p s)
instance (Arbitrary r, Arbitrary p, Arbitrary s, Arity d, Ord r, Ord s, Ord p, Num r)
=> Arbitrary (SubLine d p s r) where
arbitrary = SubLine <$> arbitrary <*> arbitrary
-- | Annotate the subRange with the actual ending points
fixEndPoints :: (Num r, Arity d) => SubLine d p r r -> SubLine d (Point d r :+ p) r r
fixEndPoints sl = sl&subRange %~ f
where
ptAt = flip pointAt (sl^.line)
label (c :+ e) = c :+ (ptAt c :+ e)
f ~(Interval l u) = Interval (l&unEndPoint %~ label)
(u&unEndPoint %~ label)
-- | forget the extra information stored at the endpoints of the subline.
dropExtra :: SubLine d p s r -> SubLine d () s r
dropExtra = over subRange (first (const ()))
-- | given point p, and a Subline l r such that p lies on line l, test if it
-- lies on the subline, i.e. in the interval r
onSubLine :: (Ord r, Fractional r, Arity d)
=> Point d r -> SubLine d p r r -> Bool
onSubLine p (SubLine l r) = case toOffset p l of
Nothing -> False
Just x -> x `intersectsInterval` r
-- | given point p, and a Subline l r such that p lies on line l, test if it
-- lies on the subline, i.e. in the interval r
onSubLine2 :: (Ord r, Num r) => Point 2 r -> SubLine 2 p r r -> Bool
p `onSubLine2` sl = d `intersectsInterval` r
where
-- get the endpoints (a,b) of the subline
SubLine _ (Interval s e) = fixEndPoints sl
a = s^.unEndPoint.extra.core
b = e^.unEndPoint.extra.core
d = (p .-. a) `dot` (b .-. a)
-- map to an interval corresponding to the length of the segment
r = Interval (s&unEndPoint.core .~ 0) (e&unEndPoint.core .~ squaredEuclideanDist b a)
type instance IntersectionOf (SubLine 2 p s r) (SubLine 2 q s r) =
[ NoIntersection, Point 2 r, SubLine 2 (Either p q) s r]
instance (Ord r, Fractional r) =>
SubLine 2 p r r `HasIntersectionWith` SubLine 2 q r r
-- -- | Given two sublines that supposedly have the same line (but
-- -- possibly represented differently), test if they intersect.
-- intersectsSLRange :: SubLine 2 p r r -> SubLine 2 q r r -> Bool
-- intersectsSLRange = undefined
-- -- | Given two sublines of the s ame line (but possibly represented differently)
-- -- align the first one to the second one.
-- --
-- -- pre: the
-- alignTo :: (Eq r, Num r, Arity d) => SubLine d p r r -> SubLine d q r r -> SubLine d p r r
-- sl `alignTo` (SubLine l@(Line p v) i2) = SubLine l i'
-- where
-- SubLine (Line q u) i = reorient sl v
-- i' = undefined
-- | Given a subline with vector u, and a vector v that is parallel to
-- u (but possibly pointing in the exact opposite direction). Make the
-- subline point in direction v as well (but keep the magnitude of the
-- original vector.)
--
-- pre: the lines are parallel.
reorient :: (Eq r,Num r, Arity d) => SubLine d p r r -> Vector d r -> SubLine d p r r
reorient sl@(SubLine (Line p u) i) v
| sameDirection u v = sl
| otherwise = SubLine (Line p ((-1) *^ u)) (flipInterval i)
{- HLINT ignore "Redundant bracket" -}
instance (Ord r, Fractional r) =>
SubLine 2 p r r `IsIntersectableWith` SubLine 2 q r r where
nonEmptyIntersection = defaultNonEmptyIntersection
sl@(SubLine l r) `intersect` sm@(SubLine m _) = match (l `intersect` m) $
H (\NoIntersection -> coRec NoIntersection)
:& H (\p@(Point _) -> if onSubLine2 p sl && onSubLine2 p sm
then coRec p
else coRec NoIntersection)
:& H (\_ -> match (r `intersect` s'') $
H coRec -- NoIntersection
:& H (coRec . SubLine l)
:& RNil
)
:& RNil
where
s' = (fixEndPoints sm)^.subRange
s'' = asProperInterval . first (^.extra)
$ s'&start.core .~ toOffset' (s'^.start.extra.core) l
&end.core .~ toOffset' (s'^.end.extra.core) l
-- testL :: SubLine 2 () (UnBounded Rational)
-- testL = SubLine (horizontalLine 0) (Interval (Closed (only 0)) (Open $ only 10))
-- horL :: SubLine 2 () (UnBounded Rational)
-- horL = fromLine $ horizontalLine 0
-- test = (testL^.subRange) `intersect` (horL^.subRange)
-- toOffset (Point2 minInfinity minInfinity) (horizontalLine 0)
-- testzz = let f = bimap (fmap Val) (const ())
-- in
-- testz :: SubLine 2 () Rational Rational
-- testz = SubLine (Line (Point2 0 0) (Vector2 10 0))
-- (Interval (Closed (0 % 1 :+ ())) (Closed (1 % 1 :+ ())))
--------------------------------------------------------------------------------
-- * Anything that deals with Unbounded intervals
-- | Create a SubLine that covers the original line from -infinity to +infinity.
fromLine :: Arity d => Line d r -> SubLine d () (UnBounded r) r
fromLine l = SubLine l (ClosedInterval (ext MinInfinity) (ext MaxInfinity))
-- | Prism for downcasting an unbounded subline to a subline.
_unBounded :: Prism' (SubLine d p (UnBounded r) r) (SubLine d p r r)
_unBounded = prism' toUnbounded fromUnbounded
-- | Transform into an subline with a potentially unbounded interval
toUnbounded :: SubLine d p r r -> SubLine d p (UnBounded r) r
toUnbounded = over subRange (fmap Val)
-- | Try to make a potentially unbounded subline into a bounded one.
fromUnbounded :: SubLine d p (UnBounded r) r -> Maybe (SubLine d p r r)
fromUnbounded (SubLine l i) = SubLine l <$> mapM unBoundedToMaybe i
-- | Get the endpoints of an unbounded interval
getEndPointsUnBounded :: (Num r, Arity d) => SubLine d p (UnBounded r) r
-> Interval p (UnBounded (Point d r))
getEndPointsUnBounded sl = second (fmap f) $ sl^.subRange
where
f = flip pointAt (sl^.line)
-- | given point p, and a Subline l r such that p lies on line l, test if it
-- lies on the subline, i.e. in the interval r
onSubLineUB :: (Ord r, Fractional r)
=> Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool
p `onSubLineUB` (SubLine l r) =
p `onLine2` l &&
Val (toOffset' p l) `intersectsInterval` r
inSubLineIntervalUB :: (Ord r, Fractional r)
=> Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool
p `inSubLineIntervalUB` (SubLine l r) = Val (toOffset' p l) `intersectsInterval` r
-- | given point p, and a Subline l r such that p lies on line l, test if it
-- lies on the subline, i.e. in the interval r
onSubLine2UB :: (Ord r, Fractional r)
=> Point 2 r -> SubLine 2 p (UnBounded r) r -> Bool
p `onSubLine2UB` sl = p `onSubLineUB` sl
--------
instance (Ord r, Fractional r) =>
SubLine 2 p (UnBounded r) r `HasIntersectionWith` SubLine 2 q (UnBounded r) r
instance (Ord r, Fractional r) =>
SubLine 2 p (UnBounded r) r `IsIntersectableWith` SubLine 2 q (UnBounded r) r where
nonEmptyIntersection = defaultNonEmptyIntersection
sl@(SubLine l r) `intersect` sm@(SubLine m _) = match (l `intersect` m) $
H (\NoIntersection -> coRec NoIntersection)
:& H (\p@(Point _) -> if inSubLineIntervalUB p sl && inSubLineIntervalUB p sm
then coRec p
else coRec NoIntersection)
:& H (\_ -> match (r `intersect` s'') $
H coRec -- NoIntersection
:& H (coRec . SubLine l)
:& RNil
)
:& RNil
where
-- convert to points, then convert back to 'r' values (but now w.r.t. l)
s' = getEndPointsUnBounded sm
s'' = second (fmap f) s'
f = flip toOffset' l