{-# LANGUAGE ScopedTypeVariables #-}
module Algorithms.Geometry.LineSegmentIntersection.BooleanSweep
( hasIntersections
) where
import Control.Lens hiding (contains)
import Data.Ext
import Data.Geometry.Interval
import Data.Geometry.LineSegment
import Data.Geometry.Point
import Data.Intersection
import qualified Data.List as L
import Data.Maybe
import Data.Ord (Down (..), comparing)
import qualified Data.Set as SS
import qualified Data.Set.Util as SS
import Debug.Trace
import Data.Geometry.Polygon
hasIntersections :: (Ord r, Num r)
=> [LineSegment 2 p r :+ e] -> Bool
hasIntersections :: [LineSegment 2 p r :+ e] -> Bool
hasIntersections [LineSegment 2 p r :+ e]
ss = [Event p r] -> StatusStructure p r -> Bool
forall r p.
(Ord r, Num r) =>
[Event p r] -> StatusStructure p r -> Bool
sweep [Event p r]
pts StatusStructure p r
forall a. Set a
SS.empty
where
pts :: [Event p r]
pts = (Event p r -> Event p r -> Ordering) -> [Event p r] -> [Event p r]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Event p r -> Event p r -> Ordering
forall r p. (Num r, Ord r) => Event p r -> Event p r -> Ordering
ordEvents ([Event p r] -> [Event p r])
-> ([LineSegment 2 p r :+ e] -> [Event p r])
-> [LineSegment 2 p r :+ e]
-> [Event p r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LineSegment 2 p r :+ e) -> [Event p r])
-> [LineSegment 2 p r :+ e] -> [Event p r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (LineSegment 2 p r :+ e) -> [Event p r]
forall r p e. Ord r => (LineSegment 2 p r :+ e) -> [Event p r]
asEventPts ([LineSegment 2 p r :+ e] -> [Event p r])
-> [LineSegment 2 p r :+ e] -> [Event p r]
forall a b. (a -> b) -> a -> b
$ [LineSegment 2 p r :+ e]
ss
asEventPts :: Ord r => LineSegment 2 p r :+ e -> [Event p r]
asEventPts :: (LineSegment 2 p r :+ e) -> [Event p r]
asEventPts (LineSegment 2 p r
s :+ e
_) =
case Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints (LineSegment 2 p r
sLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (LineSegment 2 p r
sLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) of
Ordering
LT -> [LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Insert LineSegment 2 p r
s, LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Delete LineSegment 2 p r
s]
Ordering
_ -> let LineSegment EndPoint (Point 2 r :+ p)
a EndPoint (Point 2 r :+ p)
b = LineSegment 2 p r
s
s' :: LineSegment 2 p r
s' = EndPoint (Point 2 r :+ p)
-> EndPoint (Point 2 r :+ p) -> LineSegment 2 p r
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment EndPoint (Point 2 r :+ p)
b EndPoint (Point 2 r :+ p)
a
in [LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Insert LineSegment 2 p r
s', LineSegment 2 p r -> Event p r
forall p r. LineSegment 2 p r -> Event p r
Delete LineSegment 2 p r
s']
data Event p r = Insert (LineSegment 2 p r) | Delete (LineSegment 2 p r)
deriving (Int -> Event p r -> ShowS
[Event p r] -> ShowS
Event p r -> String
(Int -> Event p r -> ShowS)
-> (Event p r -> String)
-> ([Event p r] -> ShowS)
-> Show (Event p r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p r. (Show r, Show p) => Int -> Event p r -> ShowS
forall p r. (Show r, Show p) => [Event p r] -> ShowS
forall p r. (Show r, Show p) => Event p r -> String
showList :: [Event p r] -> ShowS
$cshowList :: forall p r. (Show r, Show p) => [Event p r] -> ShowS
show :: Event p r -> String
$cshow :: forall p r. (Show r, Show p) => Event p r -> String
showsPrec :: Int -> Event p r -> ShowS
$cshowsPrec :: forall p r. (Show r, Show p) => Int -> Event p r -> ShowS
Show)
eventPoint :: Event p r -> Point 2 r
eventPoint :: Event p r -> Point 2 r
eventPoint (Insert LineSegment 2 p r
l) = LineSegment 2 p r
lLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
eventPoint (Delete LineSegment 2 p r
l) = LineSegment 2 p r
lLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
ordEvents :: (Num r, Ord r) => Event p r -> Event p r -> Ordering
ordEvents :: Event p r -> Event p r -> Ordering
ordEvents Event p r
e1 Event p r
e2 = Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints (Event p r -> Point 2 r
forall p r. Event p r -> Point 2 r
eventPoint Event p r
e1) (Event p r -> Point 2 r
forall p r. Event p r -> Point 2 r
eventPoint Event p r
e2) Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Event p r -> Event p r -> Ordering
forall p r p r. Event p r -> Event p r -> Ordering
cmpType Event p r
e1 Event p r
e2
where
cmpType :: Event p r -> Event p r -> Ordering
cmpType Insert{} Delete{} = Ordering
LT
cmpType Delete{} Insert{} = Ordering
GT
cmpType Event p r
_ Event p r
_ = Ordering
EQ
ordPoints :: Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints :: Point 2 r -> Point 2 r -> Ordering
ordPoints Point 2 r
a Point 2 r
b = let f :: point d b -> (Down b, b)
f point d b
p = (b -> Down b
forall a. a -> Down a
Down (b -> Down b) -> b -> Down b
forall a b. (a -> b) -> a -> b
$ point d b
ppoint d b -> Getting b (point d b) b -> b
forall s a. s -> Getting a s a -> a
^.Getting b (point d b) b
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord, point d b
ppoint d b -> Getting b (point d b) b -> b
forall s a. s -> Getting a s a -> a
^.Getting b (point d b) b
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) in (Point 2 r -> (Down r, r)) -> Point 2 r -> Point 2 r -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Point 2 r -> (Down r, r)
forall (d :: Nat) (point :: Nat -> * -> *) b.
(ImplicitPeano (Peano d), ArityPeano (Peano (FromPeano (Peano d))),
KnownNat (FromPeano (Peano d)), KnownNat d, AsAPoint point,
(1 <=? d) ~ 'True, (2 <=? d) ~ 'True,
Peano (FromPeano (Peano d) + 1)
~ 'S (Peano (FromPeano (Peano d)))) =>
point d b -> (Down b, b)
f Point 2 r
a Point 2 r
b
type StatusStructure p r = SS.Set (LineSegment 2 p r)
sweep :: forall r p. (Ord r, Num r)
=> [Event p r] -> StatusStructure p r
-> Bool
sweep :: [Event p r] -> StatusStructure p r -> Bool
sweep [] StatusStructure p r
_ = Bool
False
sweep (Delete LineSegment 2 p r
l:[Event p r]
eq) StatusStructure p r
ss =
Bool
overlaps Bool -> Bool -> Bool
|| [Event p r] -> StatusStructure p r -> Bool
forall r p.
(Ord r, Num r) =>
[Event p r] -> StatusStructure p r -> Bool
sweep [Event p r]
eq StatusStructure p r
ss'
where
p :: Point 2 r
p = LineSegment 2 p r
lLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
(StatusStructure p r
before,[LineSegment 2 p r]
_contains,StatusStructure p r
after) = Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
forall r p.
(Num r, Ord r) =>
Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
splitBeforeAfter Point 2 r
p StatusStructure p r
ss
overlaps :: Bool
overlaps = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects (LineSegment 2 p r -> LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe (LineSegment 2 p r -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LineSegment 2 p r)
sl Maybe (LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (LineSegment 2 p r)
sr)
sl :: Maybe (LineSegment 2 p r)
sl = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure p r
before
sr :: Maybe (LineSegment 2 p r)
sr = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure p r
after
ss' :: StatusStructure p r
ss' = StatusStructure p r
before StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r
after
sweep (Insert l :: LineSegment 2 p r
l@(LineSegment EndPoint (Point 2 r :+ p)
startPoint EndPoint (Point 2 r :+ p)
_endPoint):[Event p r]
eq) StatusStructure p r
ss =
Bool
endOverlap Bool -> Bool -> Bool
|| Bool
overlaps Bool -> Bool -> Bool
|| [Event p r] -> StatusStructure p r -> Bool
forall r p.
(Ord r, Num r) =>
[Event p r] -> StatusStructure p r -> Bool
sweep [Event p r]
eq StatusStructure p r
ss'
where
p :: Point 2 r
p = LineSegment 2 p r
lLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core
(StatusStructure p r
before,[LineSegment 2 p r]
contains,StatusStructure p r
after) = Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
forall r p.
(Num r, Ord r) =>
Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
splitBeforeAfter Point 2 r
p StatusStructure p r
ss
endOverlap :: Bool
endOverlap = EndPoint (Point 2 r :+ p) -> Bool
forall a. EndPoint a -> Bool
isClosed EndPoint (Point 2 r :+ p)
startPoint Bool -> Bool -> Bool
&& (LineSegment 2 p r -> Bool) -> [LineSegment 2 p r] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Point 2 r
p Point 2 r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
`intersects`) [LineSegment 2 p r]
contains
overlaps :: Bool
overlaps =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects LineSegment 2 p r
l (LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LineSegment 2 p r)
sl)
, Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (LineSegment 2 p r -> LineSegment 2 p r -> Bool
forall g h. HasIntersectionWith g h => g -> h -> Bool
intersects LineSegment 2 p r
l (LineSegment 2 p r -> Bool)
-> Maybe (LineSegment 2 p r) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LineSegment 2 p r)
sr) ]
sl :: Maybe (LineSegment 2 p r)
sl = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMax StatusStructure p r
before
sr :: Maybe (LineSegment 2 p r)
sr = StatusStructure p r -> Maybe (LineSegment 2 p r)
forall a. Set a -> Maybe a
SS.lookupMin StatusStructure p r
after
ss' :: StatusStructure p r
ss' = StatusStructure p r
before StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` LineSegment 2 p r -> StatusStructure p r
forall a. a -> Set a
SS.singleton LineSegment 2 p r
l StatusStructure p r -> StatusStructure p r -> StatusStructure p r
forall a. Set a -> Set a -> Set a
`SS.join` StatusStructure p r
after
splitBeforeAfter :: (Num r, Ord r)
=> Point 2 r -> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r],StatusStructure p r)
splitBeforeAfter :: Point 2 r
-> StatusStructure p r
-> (StatusStructure p r, [LineSegment 2 p r], StatusStructure p r)
splitBeforeAfter Point 2 r
p StatusStructure p r
ss = (StatusStructure p r
before, (LineSegment 2 p r -> Bool)
-> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (LineSegment 2 p r -> Bool) -> LineSegment 2 p r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point 2 r -> LineSegment 2 p r -> Bool
forall r p. Ord r => Point 2 r -> LineSegment 2 p r -> Bool
endsAt Point 2 r
p) ([LineSegment 2 p r] -> [LineSegment 2 p r])
-> [LineSegment 2 p r] -> [LineSegment 2 p r]
forall a b. (a -> b) -> a -> b
$ StatusStructure p r -> [LineSegment 2 p r]
forall a. Set a -> [a]
SS.toList StatusStructure p r
contains, StatusStructure p r
after)
where
(StatusStructure p r
before,StatusStructure p r
contains,StatusStructure p r
after) = (LineSegment 2 p r -> Ordering)
-> StatusStructure p r
-> (StatusStructure p r, StatusStructure p r, StatusStructure p r)
forall a. (a -> Ordering) -> Set a -> (Set a, Set a, Set a)
SS.splitBy LineSegment 2 p r -> Ordering
cmpLine StatusStructure p r
ss
cmpLine :: LineSegment 2 p r -> Ordering
cmpLine LineSegment 2 p r
line
| LineSegment 2 p r -> Bool
forall r p. Eq r => LineSegment 2 p r -> Bool
isHorizontal LineSegment 2 p r
line =
let [Point 2 r
_top,Point 2 r
bot] = (Point 2 r -> Point 2 r -> Ordering) -> [Point 2 r] -> [Point 2 r]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints [LineSegment 2 p r
lineLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core,LineSegment 2 p r
lineLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core] in
(Point 2 r
botPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord) r -> r -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Point 2 r
pPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord)
cmpLine LineSegment 2 p r
line =
let [Point 2 r
top,Point 2 r
bot] = (Point 2 r -> Point 2 r -> Ordering) -> [Point 2 r] -> [Point 2 r]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Point 2 r -> Point 2 r -> Ordering
forall r. Ord r => Point 2 r -> Point 2 r -> Ordering
ordPoints [LineSegment 2 p r
lineLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core,LineSegment 2 p r
lineLineSegment 2 p r
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> LineSegment 2 p r -> Const (Point 2 r) (LineSegment 2 p r))
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (LineSegment 2 p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core] in
case Point 2 r -> Point 2 r -> Point 2 r -> CCW
forall r.
(Ord r, Num r) =>
Point 2 r -> Point 2 r -> Point 2 r -> CCW
ccw Point 2 r
bot Point 2 r
top Point 2 r
p of
CCW
CW -> Ordering
LT
CCW
CoLinear -> Ordering
EQ
CCW
CCW -> Ordering
GT
isHorizontal :: Eq r => LineSegment 2 p r -> Bool
isHorizontal :: LineSegment 2 p r -> Bool
isHorizontal LineSegment 2 p r
s = LineSegment 2 p r
sLineSegment 2 p r -> Getting r (LineSegment 2 p r) r -> r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasStart t => Lens' t (StartCore t :+ StartExtra t)
start(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (LineSegment 2 p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== LineSegment 2 p r
sLineSegment 2 p r -> Getting r (LineSegment 2 p r) r -> r
forall s a. s -> Getting a s a -> a
^.((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r)
forall t. HasEnd t => Lens' t (EndCore t :+ EndExtra t)
end(((Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> LineSegment 2 p r -> Const r (LineSegment 2 p r))
-> ((r -> Const r r)
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> Getting r (LineSegment 2 p r) r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core((Point 2 r -> Const r (Point 2 r))
-> (Point 2 r :+ p) -> Const r (Point 2 r :+ p))
-> ((r -> Const r r) -> Point 2 r -> Const r (Point 2 r))
-> (r -> Const r r)
-> (Point 2 r :+ p)
-> Const r (Point 2 r :+ p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(r -> Const r r) -> Point 2 r -> Const r (Point 2 r)
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord
endsAt :: Ord r => Point 2 r -> LineSegment 2 p r -> Bool
endsAt :: Point 2 r -> LineSegment 2 p r -> Bool
endsAt Point 2 r
p (LineSegment EndPoint (Point 2 r :+ p)
_ EndPoint (Point 2 r :+ p)
b) = ((Point 2 r :+ p) -> Point 2 r)
-> EndPoint (Point 2 r :+ p) -> EndPoint (Point 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
-> (Point 2 r :+ p) -> Point 2 r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) EndPoint (Point 2 r :+ p)
b EndPoint (Point 2 r) -> EndPoint (Point 2 r) -> Bool
forall a. Eq a => a -> a -> Bool
== Point 2 r -> EndPoint (Point 2 r)
forall a. a -> EndPoint a
Open Point 2 r
p
bug' :: Bool
bug' = [LineSegment 2 () Int :+ ()] -> Bool
forall r p e. (Ord r, Num r) => [LineSegment 2 p r :+ e] -> Bool
hasIntersections ([LineSegment 2 () Int :+ ()] -> Bool)
-> [LineSegment 2 () Int :+ ()] -> Bool
forall a b. (a -> b) -> a -> b
$ (LineSegment 2 () Int -> LineSegment 2 () Int :+ ())
-> [LineSegment 2 () Int] -> [LineSegment 2 () Int :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map LineSegment 2 () Int -> LineSegment 2 () Int :+ ()
forall a. a -> a :+ ()
ext ([LineSegment 2 () Int] -> [LineSegment 2 () Int :+ ()])
-> [LineSegment 2 () Int] -> [LineSegment 2 () Int :+ ()]
forall a b. (a -> b) -> a -> b
$ Polygon 'Simple () Int -> [LineSegment 2 () Int]
forall (t :: PolygonType) p r. Polygon t p r -> [LineSegment 2 p r]
listEdges Polygon 'Simple () Int
bug
bug :: SimplePolygon () Int
bug :: Polygon 'Simple () Int
bug = [Point 2 Int :+ ()] -> Polygon 'Simple () Int
forall p r. (Eq r, Num r) => [Point 2 r :+ p] -> SimplePolygon p r
fromPoints ([Point 2 Int :+ ()] -> Polygon 'Simple () Int)
-> ([Point 2 Int] -> [Point 2 Int :+ ()])
-> [Point 2 Int]
-> Polygon 'Simple () Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point 2 Int -> Point 2 Int :+ ())
-> [Point 2 Int] -> [Point 2 Int :+ ()]
forall a b. (a -> b) -> [a] -> [b]
map Point 2 Int -> Point 2 Int :+ ()
forall a. a -> a :+ ()
ext ([Point 2 Int] -> Polygon 'Simple () Int)
-> [Point 2 Int] -> Polygon 'Simple () Int
forall a b. (a -> b) -> a -> b
$ [
Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
144 Int
592
, Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
336 Int
624
, Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
320 Int
544
, Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
240 Int
624
]
s1, s2 :: LineSegment 2 () Int
s1 :: LineSegment 2 () Int
s1 = String -> LineSegment 2 () Int
forall a. Read a => String -> a
read String
"LineSegment (Closed (Point2 240 620 :+ ())) (Open (Point2 320 544 :+ ()))"
s2 :: LineSegment 2 () Int
s2 = String -> LineSegment 2 () Int
forall a. Read a => String -> a
read String
"LineSegment (Closed (Point2 144 592 :+ ())) (Open (Point2 336 624 :+ ()))"
tr :: String -> b -> b
tr String
s b
x = (String, b) -> b -> b
forall a b. Show a => a -> b -> b
traceShow (String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" : ", b
x) b
x
edges' :: [LineSegment 2 () Int]
edges' :: [LineSegment 2 () Int]
edges' = [ EndPoint (Point 2 Int :+ ())
-> EndPoint (Point 2 Int :+ ()) -> LineSegment 2 () Int
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Closed (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
240 Int
624 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ())) ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Open (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
320 Int
544 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()))
, EndPoint (Point 2 Int :+ ())
-> EndPoint (Point 2 Int :+ ()) -> LineSegment 2 () Int
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Closed (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
336 Int
624 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ())) ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Open (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
144 Int
592 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()))
, EndPoint (Point 2 Int :+ ())
-> EndPoint (Point 2 Int :+ ()) -> LineSegment 2 () Int
forall (d :: Nat) r p.
EndPoint (Point d r :+ p)
-> EndPoint (Point d r :+ p) -> LineSegment d p r
LineSegment ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Closed (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
144 Int
592 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ())) ((Point 2 Int :+ ()) -> EndPoint (Point 2 Int :+ ())
forall a. a -> EndPoint a
Open (Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 Int
240 Int
624 Point 2 Int -> () -> Point 2 Int :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()))
]