module Geometry.Core (
    -- * Primitives
    -- ** 2D Vectors
      Vec2(..)
    , dotProduct
    , norm
    , normSquare
    , polar

    -- ** Lines
    , Line(..)
    , angleOfLine
    , angleBetween
    , angledLine
    , lineLength
    , moveAlongLine
    , resizeLine
    , resizeLineSymmetric
    , centerLine
    , normalizeLine
    , lineReverse
    , perpendicularBisector
    , perpendicularLineThrough
    , distanceFromLine
    , intersectInfiniteLines
    , LLIntersection(..)
    , intersectionLL
    , intersectionPoint
    , subdivideLine
    , subdivideLineByLength
    , reflection

    -- ** Polylines
    , Polyline(..)
    , polylineLength
    , polylineEdges

    -- ** Polygons
    , Polygon(..)
    , normalizePolygon
    , PolygonError(..)
    , validatePolygon
    , pointInPolygon
    , polygonAverage
    , polygonCentroid
    , polygonCircumference
    , polygonArea
    , signedPolygonArea
    , polygonEdges
    , polygonAngles
    , isConvex
    , convexHull
    , PolygonOrientation(..)
    , polygonOrientation
    , growPolygon
    , shrinkPolygon

    -- ** Circles and ellipses
    , Circle(..)
    , UnsafeTransformCircle(..)
    , toEllipse
    , Ellipse(..)

    -- ** Angles
    , Angle
    , deg
    , getDeg
    , rad
    , getRad
    , normalizeAngle
    , pseudoAngle

    -- ** Vector arithmetic
    , VectorSpace(..)
    , vsum

    -- * Transformations
    , Transform(..)
    , Transformation(..)
    , NoTransform(..)
    , translate
    , rotate
    , rotateAround
    , scale
    , scale'
    , scaleAround
    , scaleAround'
    , mirrorAlong
    , mirrorXCoords
    , mirrorYCoords
    , shear
    , decomposeTransformation

    -- * Bounding Box
    , HasBoundingBox(..)
    , BoundingBox(..)
    , NoBoundingBox(..)
    , overlappingBoundingBoxes
    , transformBoundingBox
    , FitDimension(..)
    , FitAspect(..)
    , FitAlign(..)
    , TransformBBSettings(..)
    , boundingBoxPolygon
    , insideBoundingBox
    , boundingBoxCenter
    , boundingBoxIntersection
    , boundingBoxSize
    , growBoundingBox
    , shrinkBoundingBox

    -- * Matrices
    , Mat2(..)
    , det
    , mulMV
    , mulVTM

    -- * Useful stuff
    , vectorOf
    , cross
    , direction
    , module Data.Sequential
    , Group(..)
) where



import           Algebra.Group
import           Algebra.VectorSpace
import           Control.DeepSeq
import           Control.Monad
import           Data.Bifoldable
import           Data.Bifunctor
import           Data.Default.Class
import           Data.Fixed
import           Data.Foldable
import           Data.List
import           Data.List.Extended
import qualified Data.Map            as M
import qualified Data.Set            as S
import           Data.Vector         (Vector)
import qualified System.Random.MWC   as MWC
import           Text.Printf

import Data.Sequential



-- $setup
-- >>> import           Control.Monad
-- >>> import           Data.Ord.Extended
-- >>> import           Draw
-- >>> import           Geometry.Algorithms.Sampling
-- >>> import qualified Graphics.Rendering.Cairo     as C
-- >>> import           Numerics.Interpolation
-- >>> import qualified System.Random.MWC.Extended   as MWC



data Vec2 = Vec2 !Double !Double deriving (Vec2 -> Vec2 -> Bool
(Vec2 -> Vec2 -> Bool) -> (Vec2 -> Vec2 -> Bool) -> Eq Vec2
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Vec2 -> Vec2 -> Bool
== :: Vec2 -> Vec2 -> Bool
$c/= :: Vec2 -> Vec2 -> Bool
/= :: Vec2 -> Vec2 -> Bool
Eq, Eq Vec2
Eq Vec2
-> (Vec2 -> Vec2 -> Ordering)
-> (Vec2 -> Vec2 -> Bool)
-> (Vec2 -> Vec2 -> Bool)
-> (Vec2 -> Vec2 -> Bool)
-> (Vec2 -> Vec2 -> Bool)
-> (Vec2 -> Vec2 -> Vec2)
-> (Vec2 -> Vec2 -> Vec2)
-> Ord Vec2
Vec2 -> Vec2 -> Bool
Vec2 -> Vec2 -> Ordering
Vec2 -> Vec2 -> Vec2
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Vec2 -> Vec2 -> Ordering
compare :: Vec2 -> Vec2 -> Ordering
$c< :: Vec2 -> Vec2 -> Bool
< :: Vec2 -> Vec2 -> Bool
$c<= :: Vec2 -> Vec2 -> Bool
<= :: Vec2 -> Vec2 -> Bool
$c> :: Vec2 -> Vec2 -> Bool
> :: Vec2 -> Vec2 -> Bool
$c>= :: Vec2 -> Vec2 -> Bool
>= :: Vec2 -> Vec2 -> Bool
$cmax :: Vec2 -> Vec2 -> Vec2
max :: Vec2 -> Vec2 -> Vec2
$cmin :: Vec2 -> Vec2 -> Vec2
min :: Vec2 -> Vec2 -> Vec2
Ord, Int -> Vec2 -> ShowS
[Vec2] -> ShowS
Vec2 -> String
(Int -> Vec2 -> ShowS)
-> (Vec2 -> String) -> ([Vec2] -> ShowS) -> Show Vec2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Vec2 -> ShowS
showsPrec :: Int -> Vec2 -> ShowS
$cshow :: Vec2 -> String
show :: Vec2 -> String
$cshowList :: [Vec2] -> ShowS
showList :: [Vec2] -> ShowS
Show)

instance NFData Vec2 where rnf :: Vec2 -> ()
rnf Vec2
_ = ()

instance MWC.UniformRange Vec2 where
    uniformRM :: forall g (m :: * -> *).
StatefulGen g m =>
(Vec2, Vec2) -> g -> m Vec2
uniformRM (Vec2 Double
xMin Double
yMin, Vec2 Double
xMax Double
yMax) g
gen =
        Double -> Double -> Vec2
Vec2 (Double -> Double -> Vec2) -> m Double -> m (Double -> Vec2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
MWC.uniformRM (Double
xMin, Double
xMax) g
gen m (Double -> Vec2) -> m Double -> m Vec2
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
MWC.uniformRM (Double
yMin, Double
yMax) g
gen

-- | Explicit type for polylines. Useful in type signatures, beacuse [[[Vec2]]] is
-- really hard to read. Also makes some typeclass instances clearer, such as
-- 'sketch'.
newtype Polyline = Polyline [Vec2]

instance Eq Polyline where Polyline [Vec2]
a == :: Polyline -> Polyline -> Bool
== Polyline [Vec2]
b = [Vec2]
a [Vec2] -> [Vec2] -> Bool
forall a. Eq a => a -> a -> Bool
== [Vec2]
b

instance Ord Polyline where compare :: Polyline -> Polyline -> Ordering
compare (Polyline [Vec2]
a) (Polyline [Vec2]
b) = [Vec2] -> [Vec2] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Vec2]
a [Vec2]
b

instance Show Polyline where show :: Polyline -> String
show (Polyline [Vec2]
xs) = String
"Polyline " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Vec2] -> String
forall a. Show a => a -> String
show [Vec2]
xs

instance NFData Polyline where rnf :: Polyline -> ()
rnf (Polyline [Vec2]
xs) = [Vec2] -> ()
forall a. NFData a => a -> ()
rnf [Vec2]
xs

-- | Polygon, defined by its corners.
--
-- Many algorithms assume certain invariants about polygons, see
-- 'validatePolygon' for details.
newtype Polygon = Polygon [Vec2]

instance NFData Polygon where rnf :: Polygon -> ()
rnf (Polygon [Vec2]
xs) = [Vec2] -> ()
forall a. NFData a => a -> ()
rnf [Vec2]
xs

-- | List-rotate the polygon’s corners until the minimum is the first entry in
-- the corner list.
normalizePolygon :: Polygon -> Polygon
normalizePolygon :: Polygon -> Polygon
normalizePolygon (Polygon [Vec2]
corners) = [Vec2] -> Polygon
Polygon ((Vec2 -> Bool) -> [Vec2] -> [Vec2]
forall a. (a -> Bool) -> [a] -> [a]
rotateUntil (Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
== [Vec2] -> Vec2
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Vec2]
corners) [Vec2]
corners)

instance Eq Polygon where
    Polygon
p1 == :: Polygon -> Polygon -> Bool
== Polygon
p2
      = let Polygon [Vec2]
p1_normalized = Polygon -> Polygon
normalizePolygon Polygon
p1
            Polygon [Vec2]
p2_normalized = Polygon -> Polygon
normalizePolygon Polygon
p2
        in [Vec2]
p1_normalized [Vec2] -> [Vec2] -> Bool
forall a. Eq a => a -> a -> Bool
== [Vec2]
p2_normalized

-- | Rotate a list until the predicate holds. If it never holds, return the
-- input list.
rotateUntil :: (a -> Bool) -> [a] -> [a]
rotateUntil :: forall a. (a -> Bool) -> [a] -> [a]
rotateUntil a -> Bool
p [a]
xs = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
    ((a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> a
forall a b. a -> b -> a
const)
    [a]
xs
    ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
cycle [a]
xs))

instance Ord Polygon where
    compare :: Polygon -> Polygon -> Ordering
compare Polygon
p1 Polygon
p2
      = let Polygon [Vec2]
p1Edges = Polygon -> Polygon
normalizePolygon Polygon
p1
            Polygon [Vec2]
p2Edges = Polygon -> Polygon
normalizePolygon Polygon
p2
        in [Vec2] -> [Vec2] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [Vec2]
p1Edges [Vec2]
p2Edges

instance Show Polygon where
    show :: Polygon -> String
show Polygon
poly = let Polygon [Vec2]
corners = Polygon -> Polygon
normalizePolygon Polygon
poly
                in String
"Polygon " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Vec2] -> String
forall a. Show a => a -> String
show [Vec2]
corners

-- | Line, defined by beginning and end.
data Line = Line !Vec2 !Vec2 deriving (Line -> Line -> Bool
(Line -> Line -> Bool) -> (Line -> Line -> Bool) -> Eq Line
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
/= :: Line -> Line -> Bool
Eq, Eq Line
Eq Line
-> (Line -> Line -> Ordering)
-> (Line -> Line -> Bool)
-> (Line -> Line -> Bool)
-> (Line -> Line -> Bool)
-> (Line -> Line -> Bool)
-> (Line -> Line -> Line)
-> (Line -> Line -> Line)
-> Ord Line
Line -> Line -> Bool
Line -> Line -> Ordering
Line -> Line -> Line
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Line -> Line -> Ordering
compare :: Line -> Line -> Ordering
$c< :: Line -> Line -> Bool
< :: Line -> Line -> Bool
$c<= :: Line -> Line -> Bool
<= :: Line -> Line -> Bool
$c> :: Line -> Line -> Bool
> :: Line -> Line -> Bool
$c>= :: Line -> Line -> Bool
>= :: Line -> Line -> Bool
$cmax :: Line -> Line -> Line
max :: Line -> Line -> Line
$cmin :: Line -> Line -> Line
min :: Line -> Line -> Line
Ord, Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
(Int -> Line -> ShowS)
-> (Line -> String) -> ([Line] -> ShowS) -> Show Line
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Line -> ShowS
showsPrec :: Int -> Line -> ShowS
$cshow :: Line -> String
show :: Line -> String
$cshowList :: [Line] -> ShowS
showList :: [Line] -> ShowS
Show)

instance NFData Line where rnf :: Line -> ()
rnf Line
_ = ()

-- | \(2\times2\) matrix.
data Mat2 = Mat2 !Double !Double !Double !Double
    -- ^ @'Mat2' a11 a12 a21 a22@ \(= \begin{pmatrix}a_{11} & a_{12}\\ a_{21} & a_{22}\end{pmatrix}\)
    deriving (Mat2 -> Mat2 -> Bool
(Mat2 -> Mat2 -> Bool) -> (Mat2 -> Mat2 -> Bool) -> Eq Mat2
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mat2 -> Mat2 -> Bool
== :: Mat2 -> Mat2 -> Bool
$c/= :: Mat2 -> Mat2 -> Bool
/= :: Mat2 -> Mat2 -> Bool
Eq, Eq Mat2
Eq Mat2
-> (Mat2 -> Mat2 -> Ordering)
-> (Mat2 -> Mat2 -> Bool)
-> (Mat2 -> Mat2 -> Bool)
-> (Mat2 -> Mat2 -> Bool)
-> (Mat2 -> Mat2 -> Bool)
-> (Mat2 -> Mat2 -> Mat2)
-> (Mat2 -> Mat2 -> Mat2)
-> Ord Mat2
Mat2 -> Mat2 -> Bool
Mat2 -> Mat2 -> Ordering
Mat2 -> Mat2 -> Mat2
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Mat2 -> Mat2 -> Ordering
compare :: Mat2 -> Mat2 -> Ordering
$c< :: Mat2 -> Mat2 -> Bool
< :: Mat2 -> Mat2 -> Bool
$c<= :: Mat2 -> Mat2 -> Bool
<= :: Mat2 -> Mat2 -> Bool
$c> :: Mat2 -> Mat2 -> Bool
> :: Mat2 -> Mat2 -> Bool
$c>= :: Mat2 -> Mat2 -> Bool
>= :: Mat2 -> Mat2 -> Bool
$cmax :: Mat2 -> Mat2 -> Mat2
max :: Mat2 -> Mat2 -> Mat2
$cmin :: Mat2 -> Mat2 -> Mat2
min :: Mat2 -> Mat2 -> Mat2
Ord, Int -> Mat2 -> ShowS
[Mat2] -> ShowS
Mat2 -> String
(Int -> Mat2 -> ShowS)
-> (Mat2 -> String) -> ([Mat2] -> ShowS) -> Show Mat2
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mat2 -> ShowS
showsPrec :: Int -> Mat2 -> ShowS
$cshow :: Mat2 -> String
show :: Mat2 -> String
$cshowList :: [Mat2] -> ShowS
showList :: [Mat2] -> ShowS
Show)

-- | Multiply a matrix \(A\) with a (column) vector \(\mathbf b\).
--
-- \[
-- \sum_i\mathbf e_i c_i = \sum_{ij}\mathbf e_i a_{ij} b_j
-- \quad\Leftrightarrow\quad
-- \begin{pmatrix}c_1\\c_2\end{pmatrix}
-- = \begin{pmatrix}a_{11}&a_{12}\\ a_{21}&a_{22}\end{pmatrix}
--       \begin{pmatrix}b_1\\ b_2\end{pmatrix}
-- = \begin{pmatrix}
--       a_{11}b_1+a_{12}b_2 \\
--       a_{21}b_1+a_{22}b_2
--   \end{pmatrix}
-- \]
mulMV :: Mat2 -> Vec2 -> Vec2
mulMV :: Mat2 -> Vec2 -> Vec2
mulMV (Mat2 Double
a11 Double
a12 Double
a21 Double
a22) (Vec2 Double
b1 Double
b2) =
    Double -> Double -> Vec2
Vec2 (Double
a11Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a12Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b2)
         (Double
a21Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a22Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b2)

-- | Multiply a (row) vector \(\mathbf a^\top\) with a matrix \(A\).
--
-- \[
-- \sum_i\mathbf e_i c_i = \sum_{ij} b_i a_{ij} \mathbf e_j
-- \quad\Leftrightarrow\quad
-- \begin{pmatrix}c_1&c_2\end{pmatrix}
-- = \begin{pmatrix}b_1&b_2\end{pmatrix}
--       \begin{pmatrix}a_{11}&a_{12}\\ a_{21}&a_{22}\end{pmatrix}
-- = \begin{pmatrix}
--       b_1a_{11}+b_2a_{21} &
--       b_1a_{12}+b_2a_{22}
--   \end{pmatrix}
-- \]
mulVTM :: Vec2 -> Mat2 -> Vec2
mulVTM :: Vec2 -> Mat2 -> Vec2
mulVTM (Vec2 Double
b1 Double
b2) (Mat2 Double
a11 Double
a12 Double
a21 Double
a22) =
    Double -> Double -> Vec2
Vec2 (Double
b1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a11 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a21)
         (Double
b1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a12 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a22)

-- | Multiplicative semigroup.
instance Semigroup Mat2 where
    Mat2   Double
a11 Double
a12
           Double
a21 Double
a22
     <> :: Mat2 -> Mat2 -> Mat2
<>
      Mat2 Double
b11 Double
b12
           Double
b21 Double
b22

     = Double -> Double -> Double -> Double -> Mat2
Mat2 (Double
a11Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b11 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a12Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b21) (Double
a11Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b12 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a12Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b22)
            (Double
a21Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b11 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a22Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b21) (Double
a21Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b12 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a22Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
b22)

-- | Multiplicative monoid.
instance Monoid Mat2 where
    mempty :: Mat2
mempty = Double -> Double -> Double -> Double -> Mat2
Mat2 Double
1 Double
0
                  Double
0 Double
1

-- | Multiplicative group.
instance Group Mat2 where
    inverse :: Mat2 -> Mat2
inverse (Mat2 Double
a Double
b
                    Double
d Double
e)
        = let x :: Double
x = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
bDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
d)
        in  Double -> Double -> Double -> Double -> Mat2
Mat2 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e)    (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(-Double
b))
                 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(-Double
d)) (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a)

instance VectorSpace Mat2 where
    Mat2 Double
a11 Double
a12 Double
a21 Double
a22 +. :: Mat2 -> Mat2 -> Mat2
+. Mat2 Double
b11 Double
b12 Double
b21 Double
b22 = Double -> Double -> Double -> Double -> Mat2
Mat2 (Double
a11Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
b11) (Double
a12Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
b12) (Double
a21Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
b21) (Double
a22Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
b22)
    Mat2 Double
a11 Double
a12 Double
a21 Double
a22 -. :: Mat2 -> Mat2 -> Mat2
-. Mat2 Double
b11 Double
b12 Double
b21 Double
b22 = Double -> Double -> Double -> Double -> Mat2
Mat2 (Double
a11Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b11) (Double
a12Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b12) (Double
a21Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b21) (Double
a22Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b22)
    Double
s *. :: Double -> Mat2 -> Mat2
*. Mat2 Double
a11 Double
a12 Double
a21 Double
a22 = Double -> Double -> Double -> Double -> Mat2
Mat2 (Double
s Double -> Double -> Double
forall v. VectorSpace v => Double -> v -> v
*. Double
a11) (Double
s Double -> Double -> Double
forall v. VectorSpace v => Double -> v -> v
*. Double
a12) (Double
s Double -> Double -> Double
forall v. VectorSpace v => Double -> v -> v
*. Double
a21) (Double
s Double -> Double -> Double
forall v. VectorSpace v => Double -> v -> v
*. Double
a22)
    zero :: Mat2
zero = Double -> Double -> Double -> Double -> Mat2
Mat2 Double
0 Double
0 Double
0 Double
0

instance NFData Mat2 where rnf :: Mat2 -> ()
rnf Mat2
_ = ()

-- | Affine transformation. Typically these are not written using the constructor
-- directly, but by combining functions such as 'translate' or 'rotateAround' using
-- '<>'.
--
-- \[
-- \begin{pmatrix}\mathbf{x'}\\1\end{pmatrix}
-- = \begin{pmatrix} A \mathbf x + \mathbf b\\1\end{pmatrix}
-- = \left(\begin{array}{c|c} A & \mathbf b \\ \hline 0 & 1\end{array}\right)
--   \begin{pmatrix}\mathbf x\\ 1\end{pmatrix}
-- \]
data Transformation =
    Transformation !Mat2 !Vec2
                    -- ^
                    -- > transformation (Mat2 a11 a12
                    -- >                      a21 a22)
                    -- >                (Vec2 b1 b2)
                    -- \(= \left(\begin{array}{cc|c} a_{11} & a_{12} & b_1 \\ a_{21} & a_{22} & b_2 \\ \hline 0 & 0 & 1\end{array}\right)\)
    deriving (Transformation -> Transformation -> Bool
(Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool) -> Eq Transformation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Transformation -> Transformation -> Bool
== :: Transformation -> Transformation -> Bool
$c/= :: Transformation -> Transformation -> Bool
/= :: Transformation -> Transformation -> Bool
Eq, Eq Transformation
Eq Transformation
-> (Transformation -> Transformation -> Ordering)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Transformation)
-> (Transformation -> Transformation -> Transformation)
-> Ord Transformation
Transformation -> Transformation -> Bool
Transformation -> Transformation -> Ordering
Transformation -> Transformation -> Transformation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Transformation -> Transformation -> Ordering
compare :: Transformation -> Transformation -> Ordering
$c< :: Transformation -> Transformation -> Bool
< :: Transformation -> Transformation -> Bool
$c<= :: Transformation -> Transformation -> Bool
<= :: Transformation -> Transformation -> Bool
$c> :: Transformation -> Transformation -> Bool
> :: Transformation -> Transformation -> Bool
$c>= :: Transformation -> Transformation -> Bool
>= :: Transformation -> Transformation -> Bool
$cmax :: Transformation -> Transformation -> Transformation
max :: Transformation -> Transformation -> Transformation
$cmin :: Transformation -> Transformation -> Transformation
min :: Transformation -> Transformation -> Transformation
Ord, Int -> Transformation -> ShowS
[Transformation] -> ShowS
Transformation -> String
(Int -> Transformation -> ShowS)
-> (Transformation -> String)
-> ([Transformation] -> ShowS)
-> Show Transformation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Transformation -> ShowS
showsPrec :: Int -> Transformation -> ShowS
$cshow :: Transformation -> String
show :: Transformation -> String
$cshowList :: [Transformation] -> ShowS
showList :: [Transformation] -> ShowS
Show)

instance NFData Transformation where rnf :: Transformation -> ()
rnf Transformation
_ = ()

-- | The order transformations are applied in function order:
--
-- @
-- 'transform' ('scale' s <> 'translate' p)
-- ==
-- 'transform' ('scale' s) . 'transform' ('translate' p)
-- @
--
-- In other words, this first translates its argument, and then scales.
-- Note that Cairo does its Canvas transformations just the other way round, since
-- in Cairo you do not move the geometry, but the coordinate system. If you wrap a
-- transformation in 'inverse', you get the Cairo behavior.
instance Semigroup Transformation where
    Transformation Mat2
m1 Vec2
v1 <> :: Transformation -> Transformation -> Transformation
<> Transformation Mat2
m2 Vec2
v2 = Mat2 -> Vec2 -> Transformation
Transformation (Mat2
m1 Mat2 -> Mat2 -> Mat2
forall a. Semigroup a => a -> a -> a
<> Mat2
m2) (Mat2
m1 Mat2 -> Vec2 -> Vec2
`mulMV` Vec2
v2 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
v1)

instance Monoid Transformation where
    mempty :: Transformation
mempty = Mat2 -> Vec2 -> Transformation
Transformation Mat2
forall a. Monoid a => a
mempty Vec2
forall v. VectorSpace v => v
zero

instance Group Transformation where
    inverse :: Transformation -> Transformation
inverse (Transformation (Mat2 Double
a Double
b
                                  Double
d Double
e)
                            (Vec2 Double
c Double
f))
        = let x :: Double
x = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
bDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
d)
        in Mat2 -> Vec2 -> Transformation
Transformation (Double -> Double -> Double -> Double -> Mat2
Mat2 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e)    (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(-Double
b))
                                (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(-Double
d)) (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a))
                          (Double -> Double -> Vec2
Vec2 (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(-Double
eDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
f))
                                (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*( Double
dDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
c Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
f)))

-- | Transform geometry using an affine transformation.
--
-- This allows for a multitude of common transformations, such as translation
-- ('translate'), rotation ('rotate') or scaling ('scale').
--
-- Simple transformations can be combined to yield more complex operations, such as
-- rotating around a point, which can be achieved by moving the center of rotation
-- to the origin, rotating, and then rotating back:
--
-- @
-- 'rotateAround' pivot angle = 'translate' pivot <> 'rotate' angle <> 'inverse' ('translate' pivot)
-- @
class Transform geo where
    transform :: Transformation -> geo -> geo

-- | Transform the result of a function.
--
-- @
-- moveRight :: 'Vec2' -> 'Vec2'
-- moveRight ('Vec2' x y) = 'Vec2' (x+1) y
--
-- moveRightThenRotate :: 'Vec2' -> 'Vec2'
-- moveRightThenRotate = 'transform' ('rotate' ('deg' 90)) moveRight
-- @
instance Transform b => Transform (a -> b) where
    transform :: Transformation -> (a -> b) -> a -> b
transform Transformation
t a -> b
f = Transformation -> b -> b
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance Transform Vec2 where
    transform :: Transformation -> Vec2 -> Vec2
transform (Transformation (Mat2 Double
a Double
b
                                    Double
d Double
e)
                              (Vec2 Double
c Double
f))
              (Vec2 Double
x Double
y)
            = Double -> Double -> Vec2
Vec2 (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
c) (Double
dDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
eDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
f)

instance Transform Line where
    transform :: Transformation -> Line -> Line
transform Transformation
t (Line Vec2
start Vec2
end) = Vec2 -> Vec2 -> Line
Line (Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t Vec2
start) (Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t Vec2
end)

instance Transform Polygon where
    transform :: Transformation -> Polygon -> Polygon
transform Transformation
t (Polygon [Vec2]
ps) = [Vec2] -> Polygon
Polygon (Transformation -> [Vec2] -> [Vec2]
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t [Vec2]
ps)

instance Transform Polyline where transform :: Transformation -> Polyline -> Polyline
transform Transformation
t (Polyline [Vec2]
xs) = [Vec2] -> Polyline
Polyline (Transformation -> [Vec2] -> [Vec2]
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t [Vec2]
xs)

instance Transform Transformation where
    transform :: Transformation -> Transformation -> Transformation
transform = Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
(<>)

-- | Points mapped to the same point will unify to a single entry
instance (Ord a, Transform a) => Transform (S.Set a) where
    transform :: Transformation -> Set a -> Set a
transform Transformation
t = (a -> a) -> Set a -> Set a
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t)

instance Transform a => Transform (M.Map k a) where
    transform :: Transformation -> Map k a -> Map k a
transform Transformation
t = (a -> a) -> Map k a -> Map k a
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t)

instance Transform a => Transform [a] where
    transform :: Transformation -> [a] -> [a]
transform Transformation
t = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t)

instance Transform a => Transform (Vector a) where
    transform :: Transformation -> Vector a -> Vector a
transform Transformation
t = (a -> a) -> Vector a -> Vector a
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t)

instance (Transform a, Transform b) => Transform (Either a b) where
    transform :: Transformation -> Either a b -> Either a b
transform Transformation
t = (a -> a) -> (b -> b) -> Either a b -> Either a b
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t) (Transformation -> b -> b
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t)

instance (Transform a, Transform b) => Transform (a,b) where
    transform :: Transformation -> (a, b) -> (a, b)
transform Transformation
t (a
a,b
b) = (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t a
a, Transformation -> b -> b
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t b
b)

instance (Transform a, Transform b, Transform c) => Transform (a,b,c) where
    transform :: Transformation -> (a, b, c) -> (a, b, c)
transform Transformation
t (a
a,b
b,c
c) = (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t a
a, Transformation -> b -> b
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t b
b, Transformation -> c -> c
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t c
c)

instance (Transform a, Transform b, Transform c, Transform d) => Transform (a,b,c,d) where
    transform :: Transformation -> (a, b, c, d) -> (a, b, c, d)
transform Transformation
t (a
a,b
b,c
c,d
d) = (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t a
a, Transformation -> b -> b
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t b
b, Transformation -> c -> c
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t c
c, Transformation -> d -> d
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t d
d)

instance (Transform a, Transform b, Transform c, Transform d, Transform e) => Transform (a,b,c,d,e) where
    transform :: Transformation -> (a, b, c, d, e) -> (a, b, c, d, e)
transform Transformation
t (a
a,b
b,c
c,d
d,e
e) = (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t a
a, Transformation -> b -> b
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t b
b, Transformation -> c -> c
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t c
c, Transformation -> d -> d
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t d
d, Transformation -> e -> e
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t e
e)

-- | Translate the argument by an offset given by the vector. @'translate' ('Vec2' 0 0) = 'mempty'@.
--
-- \[
-- \text{translate}\begin{pmatrix}\Delta_x\\\Delta_y\end{pmatrix}
--     = \left(\begin{array}{cc|c} 1 & 0 & \Delta_x \\ 0 & 1 & \Delta_y \\ \hline 0 & 0 & 1\end{array}\right)
-- \]
--
-- This effectively adds the 'Vec2' to all contained 'Vec2's in the target.
--
-- <<docs/haddock/Geometry/Core/translate.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/translate.svg" 100 50 $ \_ -> do
--     let point = Vec2 20 20
--         offset = Vec2 70 20
--         point' = transform (translate offset) point
--     sketch (Circle point 5)
--     sketch (Circle point' 5)
--     C.fill
--     setColor (mma 1)
--     sketch (Arrow (Line point point') def) >> C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x5f8c6969
translate :: Vec2 -> Transformation
translate :: Vec2 -> Transformation
translate = Mat2 -> Vec2 -> Transformation
Transformation Mat2
forall a. Monoid a => a
mempty

-- | Rotate around 'zero' in mathematically positive direction (counter-clockwise). @'rotate' ('rad' 0) = 'mempty'@.
--
-- \[
-- \text{rotate}(\alpha) = \left(\begin{array}{cc|c} \cos(\alpha) & -\sin(\alpha) & 0 \\ \sin(\alpha) & \cos(\alpha) & 0 \\ \hline 0 & 0 & 1\end{array}\right)
-- \]
--
-- To rotate around a different point, use 'rotateAround'.
--
-- <<docs/haddock/Geometry/Core/rotate.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/rotate.svg" 100 70 $ \_ -> do
--     let point = Vec2 90 10
--         angle = deg 30
--         point' = transform (rotate angle) point
--     cairoScope $ do
--         sketch (Circle point 5, Circle point' 5)
--         C.fill
--     setColor (mma 1)
--     let line = Line zero point
--         line' = Line zero point'
--     cairoScope $ do
--         C.setDash [1,1] 0
--         sketch (line, line')
--         C.stroke
--     cairoScope $ do
--         let angle = angleOfLine line
--             angle' = angleOfLine line'
--         C.arc 0 0 (lineLength line) (getRad angle) (getRad angle')
--         sketch (Arrow (transform (rotateAround point' (deg 15)) (Line point point')) def{_arrowDrawBody=False})
--         C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x980f5f
rotate :: Angle -> Transformation
rotate :: Angle -> Transformation
rotate (Rad Double
a) = Mat2 -> Vec2 -> Transformation
Transformation Mat2
m Vec2
forall v. VectorSpace v => v
zero
  where
    m :: Mat2
m = Double -> Double -> Double -> Double -> Mat2
Mat2 (Double -> Double
forall a. Floating a => a -> a
cos Double
a) (-Double -> Double
forall a. Floating a => a -> a
sin Double
a)
             (Double -> Double
forall a. Floating a => a -> a
sin Double
a) ( Double -> Double
forall a. Floating a => a -> a
cos Double
a)

-- | Rotate around a point.
rotateAround :: Vec2 -> Angle -> Transformation
rotateAround :: Vec2 -> Angle -> Transformation
rotateAround Vec2
pivot Angle
angle = Vec2 -> Transformation
translate Vec2
pivot Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Angle -> Transformation
rotate Angle
angle Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation -> Transformation
forall a. Group a => a -> a
inverse (Vec2 -> Transformation
translate Vec2
pivot)

-- | Scale the geometry relative to zero, maintaining aspect ratio.
--
-- <<docs/haddock/Geometry/Core/scale.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/scale.svg" 100 100 $ \_ -> do
--     let square = Polygon [Vec2 10 10, Vec2 10 45, Vec2 45 45, Vec2 45 10]
--         square' = transform (scale 2) square
--     sketch square
--     C.stroke
--     setColor (mma 1)
--     sketch square'
--     C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x9126ef6
scale :: Double -> Transformation
scale :: Double -> Transformation
scale Double
x = Double -> Double -> Transformation
scale' Double
x Double
x

-- | Scale the geometry with adjustable aspect ratio. @'scale'' 1 1 = 'mempty'@.
--
-- \[
-- \text{scale'}(s_x,s_y) = \left(\begin{array}{cc|c} s_x & 0 & 0 \\ 0 & s_y & 0 \\ \hline 0 & 0 & 1\end{array}\right)
-- \]
--
-- While being more general and mathematically more natural than 'scale', this
-- function is used less in practice, hence it gets the prime in the name.
scale' :: Double -> Double -> Transformation
scale' :: Double -> Double -> Transformation
scale' Double
x Double
y = Mat2 -> Vec2 -> Transformation
Transformation Mat2
m Vec2
forall v. VectorSpace v => v
zero
  where
    m :: Mat2
m = Double -> Double -> Double -> Double -> Mat2
Mat2 Double
x Double
0
             Double
0 Double
y

-- | Scale the geometry relative to a point, maintaining aspect ratio.
scaleAround :: Vec2 -> Double -> Transformation
scaleAround :: Vec2 -> Double -> Transformation
scaleAround Vec2
pivot Double
x = Vec2 -> Transformation
translate Vec2
pivot Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Transformation
scale Double
x Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation -> Transformation
forall a. Group a => a -> a
inverse (Vec2 -> Transformation
translate Vec2
pivot)

-- | Scale the geometry relative to a point, with adjustable aspect ratio.
--
-- While being more general and mathematically more natural, this function is used
-- less in practice, hence it gets the prime in the name.
scaleAround' :: Vec2 -> Double -> Double -> Transformation
scaleAround' :: Vec2 -> Double -> Double -> Transformation
scaleAround' Vec2
pivot Double
x Double
y = Vec2 -> Transformation
translate Vec2
pivot Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Transformation
scale' Double
x Double
y Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation -> Transformation
forall a. Group a => a -> a
inverse (Vec2 -> Transformation
translate Vec2
pivot)

-- | Mirror the geometry along a line.
--
-- This function is called 'mirrorAlong' and not @mirror@ since the latter makes a
-- very good name for arguments of this function.
mirrorAlong :: Line -> Transformation
mirrorAlong :: Line -> Transformation
mirrorAlong line :: Line
line@(Line Vec2
p Vec2
_) = Vec2 -> Transformation
translate Vec2
p Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Angle -> Transformation
rotate Angle
angle Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
mirrorYCoords Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation -> Transformation
forall a. Group a => a -> a
inverse (Angle -> Transformation
rotate Angle
angle) Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation -> Transformation
forall a. Group a => a -> a
inverse (Vec2 -> Transformation
translate Vec2
p)
  where
    angle :: Angle
angle = Line -> Angle
angleOfLine Line
line

-- | Invert all X coordinates.
--
-- NB: if it was called @mirrorX@ it wouldn’t be clear whether it mirrors the X
-- coordinates, or along the X axis, which would mirror the Y coordinates. The
-- longer name makes it clearer.
mirrorXCoords :: Transformation
mirrorXCoords :: Transformation
mirrorXCoords = Double -> Double -> Transformation
scale' (-Double
1) Double
1

-- | Invert all Y coordinates.
mirrorYCoords :: Transformation
mirrorYCoords :: Transformation
mirrorYCoords = Double -> Double -> Transformation
scale' Double
1 (-Double
1)

-- | Shear with a factor along x/y axis relative to zero. @'shear' 0 0 = 'mempty'@.
--
-- \[
-- \text{shear}(p,q)
--     = \left(\begin{array}{cc|c} 1 & p & 0 \\ q & 1 & 0 \\ \hline 0 & 0 & 1\end{array}\right)
-- \]
--
-- <<docs/haddock/Geometry/Core/shear.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/shear.svg" 100 100 $ \_ -> do
--     let square = Polygon [Vec2 10 10, Vec2 10 80, Vec2 50 80, Vec2 50 10]
--         square' = transform (shear 0.5 0.1) square
--     sketch square
--     C.stroke
--     setColor (mma 1)
--     sketch square'
--     C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0xfd1224e4
shear
    :: Double
    -> Double
    -> Transformation
shear :: Double -> Double -> Transformation
shear Double
p Double
q = Mat2 -> Vec2 -> Transformation
Transformation Mat2
m Vec2
forall v. VectorSpace v => v
zero
  where
    m :: Mat2
m = Double -> Double -> Double -> Double -> Mat2
Mat2 Double
1 Double
p
             Double
q Double
1

-- | This type simply wraps its contents, and makes 'transform' do nothing.
-- It’s a very useful type when you want to e.g. resize the whole geometry given to
-- your rendering function, but it contains some non-geometrical render data, like
-- a timestamp for each shape.
newtype NoTransform a = NoTransform a
    deriving (NoTransform a -> NoTransform a -> Bool
(NoTransform a -> NoTransform a -> Bool)
-> (NoTransform a -> NoTransform a -> Bool) -> Eq (NoTransform a)
forall a. Eq a => NoTransform a -> NoTransform a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => NoTransform a -> NoTransform a -> Bool
== :: NoTransform a -> NoTransform a -> Bool
$c/= :: forall a. Eq a => NoTransform a -> NoTransform a -> Bool
/= :: NoTransform a -> NoTransform a -> Bool
Eq, Eq (NoTransform a)
Eq (NoTransform a)
-> (NoTransform a -> NoTransform a -> Ordering)
-> (NoTransform a -> NoTransform a -> Bool)
-> (NoTransform a -> NoTransform a -> Bool)
-> (NoTransform a -> NoTransform a -> Bool)
-> (NoTransform a -> NoTransform a -> Bool)
-> (NoTransform a -> NoTransform a -> NoTransform a)
-> (NoTransform a -> NoTransform a -> NoTransform a)
-> Ord (NoTransform a)
NoTransform a -> NoTransform a -> Bool
NoTransform a -> NoTransform a -> Ordering
NoTransform a -> NoTransform a -> NoTransform a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (NoTransform a)
forall a. Ord a => NoTransform a -> NoTransform a -> Bool
forall a. Ord a => NoTransform a -> NoTransform a -> Ordering
forall a. Ord a => NoTransform a -> NoTransform a -> NoTransform a
$ccompare :: forall a. Ord a => NoTransform a -> NoTransform a -> Ordering
compare :: NoTransform a -> NoTransform a -> Ordering
$c< :: forall a. Ord a => NoTransform a -> NoTransform a -> Bool
< :: NoTransform a -> NoTransform a -> Bool
$c<= :: forall a. Ord a => NoTransform a -> NoTransform a -> Bool
<= :: NoTransform a -> NoTransform a -> Bool
$c> :: forall a. Ord a => NoTransform a -> NoTransform a -> Bool
> :: NoTransform a -> NoTransform a -> Bool
$c>= :: forall a. Ord a => NoTransform a -> NoTransform a -> Bool
>= :: NoTransform a -> NoTransform a -> Bool
$cmax :: forall a. Ord a => NoTransform a -> NoTransform a -> NoTransform a
max :: NoTransform a -> NoTransform a -> NoTransform a
$cmin :: forall a. Ord a => NoTransform a -> NoTransform a -> NoTransform a
min :: NoTransform a -> NoTransform a -> NoTransform a
Ord, Int -> NoTransform a -> ShowS
[NoTransform a] -> ShowS
NoTransform a -> String
(Int -> NoTransform a -> ShowS)
-> (NoTransform a -> String)
-> ([NoTransform a] -> ShowS)
-> Show (NoTransform a)
forall a. Show a => Int -> NoTransform a -> ShowS
forall a. Show a => [NoTransform a] -> ShowS
forall a. Show a => NoTransform a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> NoTransform a -> ShowS
showsPrec :: Int -> NoTransform a -> ShowS
$cshow :: forall a. Show a => NoTransform a -> String
show :: NoTransform a -> String
$cshowList :: forall a. Show a => [NoTransform a] -> ShowS
showList :: [NoTransform a] -> ShowS
Show, ReadPrec [NoTransform a]
ReadPrec (NoTransform a)
Int -> ReadS (NoTransform a)
ReadS [NoTransform a]
(Int -> ReadS (NoTransform a))
-> ReadS [NoTransform a]
-> ReadPrec (NoTransform a)
-> ReadPrec [NoTransform a]
-> Read (NoTransform a)
forall a. Read a => ReadPrec [NoTransform a]
forall a. Read a => ReadPrec (NoTransform a)
forall a. Read a => Int -> ReadS (NoTransform a)
forall a. Read a => ReadS [NoTransform a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (NoTransform a)
readsPrec :: Int -> ReadS (NoTransform a)
$creadList :: forall a. Read a => ReadS [NoTransform a]
readList :: ReadS [NoTransform a]
$creadPrec :: forall a. Read a => ReadPrec (NoTransform a)
readPrec :: ReadPrec (NoTransform a)
$creadListPrec :: forall a. Read a => ReadPrec [NoTransform a]
readListPrec :: ReadPrec [NoTransform a]
Read, NoTransform a
NoTransform a -> NoTransform a -> Bounded (NoTransform a)
forall a. a -> a -> Bounded a
forall a. Bounded a => NoTransform a
$cminBound :: forall a. Bounded a => NoTransform a
minBound :: NoTransform a
$cmaxBound :: forall a. Bounded a => NoTransform a
maxBound :: NoTransform a
Bounded)

instance NFData a => NFData (NoTransform a) where rnf :: NoTransform a -> ()
rnf (NoTransform a
x) = a -> ()
forall a. NFData a => a -> ()
rnf a
x
instance Enum a => Enum (NoTransform a) where
    toEnum :: Int -> NoTransform a
toEnum = a -> NoTransform a
forall a. a -> NoTransform a
NoTransform (a -> NoTransform a) -> (Int -> a) -> Int -> NoTransform a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a. Enum a => Int -> a
toEnum
    fromEnum :: NoTransform a -> Int
fromEnum (NoTransform a
x) = a -> Int
forall a. Enum a => a -> Int
fromEnum a
x
instance HasBoundingBox a => HasBoundingBox (NoTransform a) where boundingBox :: NoTransform a -> BoundingBox
boundingBox (NoTransform a
x) = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
x
instance Semigroup a => Semigroup (NoTransform a) where NoTransform a
x <> :: NoTransform a -> NoTransform a -> NoTransform a
<> NoTransform a
y = a -> NoTransform a
forall a. a -> NoTransform a
NoTransform (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
instance Monoid a => Monoid (NoTransform a) where mempty :: NoTransform a
mempty = a -> NoTransform a
forall a. a -> NoTransform a
NoTransform a
forall a. Monoid a => a
mempty
-- | Don’t transform the contents.
instance Transform (NoTransform a) where transform :: Transformation -> NoTransform a -> NoTransform a
transform Transformation
_ NoTransform a
x = NoTransform a
x

-- | Decompose an affine transformation into scale, shear, rotation and translation parts.
-- This composition is not unique, since scale, shear and rotating can be done in different orders.
--
-- Our choice of decomposition is:
--
-- \[
-- \left(\begin{array}{cc|c} a_{11} & a_{12} & b_1 \\ a_{21} & a_{22} & b_2 \\ \hline & & 1\end{array}\right)
-- =
-- \underbrace{\left(\begin{array}{cc|c} 1 & & \Delta_x \\ & 1 & \Delta_y \\ \hline & & 1\end{array}\right)}                                    _{\text{translate}(\Delta_x, \Delta_y)}
-- \underbrace{\left(\begin{array}{cc|c} s_x & & \\ & s_y & \\ \hline & & 1\end{array}\right)}                                                  _{\text{scale}'(s_x,s_y)}
-- \underbrace{\left(\begin{array}{cc|c} 1 & & \\ \sigma_y & 1 & \\ \hline & & 1\end{array}\right)}                                             _{\text{shear}(0, \sigma_y)}
-- \underbrace{\left(\begin{array}{cc|c} \cos(\varphi) & -\sin(\varphi) & \\ \sin(\varphi) & \cos(\varphi) & \\ \hline & & 1\end{array}\right)} _{\text{rotatate}(\varphi)}
-- \]
decomposeTransformation
    :: Transformation
    -> (Vec2, (Double, Double), Double, Angle) -- ^ \(\Delta\mathbf v, (\text{scale}_x,\text{scale}_y), \text{shear}_y, \varphi\)
decomposeTransformation :: Transformation -> (Vec2, (Double, Double), Double, Angle)
decomposeTransformation (Transformation m :: Mat2
m@(Mat2 Double
a Double
b Double
d Double
e) Vec2
cf) =
    -- Source: https://math.stackexchange.com/a/78165/21079
    let p :: Double
p = Double -> Double
forall a. Floating a => a -> a
sqrt (Double
aDouble -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bDouble -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
        detM :: Double
detM = Mat2 -> Double
det Mat2
m
        r :: Double
r = Double
detM Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
p
        q :: Double
q = (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
e) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
detM
        phi :: Double
phi = - Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 Double
b Double
a -- minus because of left-handed Cairo coordinates
    in (Vec2
cf, (Double
p,Double
r), Double
q, Double -> Angle
rad Double
phi)

-- | The bounding box, with the minimum and maximum vectors.
--
-- In geometrical terms, the bounding box is a rectangle spanned by the bottom-left
-- (minimum) and top-right (maximum) points, so that everything is inside the
-- rectangle.
--
-- __Invariant!__ Make sure the first argument is smaller than the second when
-- using the constructor directly! Or better yet, don’t use the constructor and
-- create bounding boxes via the provided instances; for a rectangle, simply use
-- @'boundingBox' (a,b)@ instead of @'BoundingBox' a b@.
data BoundingBox = BoundingBox !Vec2 !Vec2 deriving (BoundingBox -> BoundingBox -> Bool
(BoundingBox -> BoundingBox -> Bool)
-> (BoundingBox -> BoundingBox -> Bool) -> Eq BoundingBox
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BoundingBox -> BoundingBox -> Bool
== :: BoundingBox -> BoundingBox -> Bool
$c/= :: BoundingBox -> BoundingBox -> Bool
/= :: BoundingBox -> BoundingBox -> Bool
Eq, Eq BoundingBox
Eq BoundingBox
-> (BoundingBox -> BoundingBox -> Ordering)
-> (BoundingBox -> BoundingBox -> Bool)
-> (BoundingBox -> BoundingBox -> Bool)
-> (BoundingBox -> BoundingBox -> Bool)
-> (BoundingBox -> BoundingBox -> Bool)
-> (BoundingBox -> BoundingBox -> BoundingBox)
-> (BoundingBox -> BoundingBox -> BoundingBox)
-> Ord BoundingBox
BoundingBox -> BoundingBox -> Bool
BoundingBox -> BoundingBox -> Ordering
BoundingBox -> BoundingBox -> BoundingBox
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BoundingBox -> BoundingBox -> Ordering
compare :: BoundingBox -> BoundingBox -> Ordering
$c< :: BoundingBox -> BoundingBox -> Bool
< :: BoundingBox -> BoundingBox -> Bool
$c<= :: BoundingBox -> BoundingBox -> Bool
<= :: BoundingBox -> BoundingBox -> Bool
$c> :: BoundingBox -> BoundingBox -> Bool
> :: BoundingBox -> BoundingBox -> Bool
$c>= :: BoundingBox -> BoundingBox -> Bool
>= :: BoundingBox -> BoundingBox -> Bool
$cmax :: BoundingBox -> BoundingBox -> BoundingBox
max :: BoundingBox -> BoundingBox -> BoundingBox
$cmin :: BoundingBox -> BoundingBox -> BoundingBox
min :: BoundingBox -> BoundingBox -> BoundingBox
Ord, Int -> BoundingBox -> ShowS
[BoundingBox] -> ShowS
BoundingBox -> String
(Int -> BoundingBox -> ShowS)
-> (BoundingBox -> String)
-> ([BoundingBox] -> ShowS)
-> Show BoundingBox
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BoundingBox -> ShowS
showsPrec :: Int -> BoundingBox -> ShowS
$cshow :: BoundingBox -> String
show :: BoundingBox -> String
$cshowList :: [BoundingBox] -> ShowS
showList :: [BoundingBox] -> ShowS
Show)

instance NFData BoundingBox where rnf :: BoundingBox -> ()
rnf BoundingBox
_ = ()

instance Semigroup BoundingBox where
    BoundingBox (Vec2 Double
xMin1 Double
yMin1) (Vec2 Double
xMax1 Double
yMax1) <> :: BoundingBox -> BoundingBox -> BoundingBox
<> BoundingBox (Vec2 Double
xMin2 Double
yMin2) (Vec2 Double
xMax2 Double
yMax2)
      = Vec2 -> Vec2 -> BoundingBox
BoundingBox (Double -> Double -> Vec2
Vec2 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
xMin1 Double
xMin2) (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
yMin1 Double
yMin2))
                    (Double -> Double -> Vec2
Vec2 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
xMax1 Double
xMax2) (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
yMax1 Double
yMax2))

instance Transform BoundingBox where
    transform :: Transformation -> BoundingBox -> BoundingBox
transform Transformation
t (BoundingBox Vec2
lo Vec2
hi) = Vec2 -> Vec2 -> BoundingBox
BoundingBox (Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t Vec2
lo) (Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t Vec2
hi)

-- | A bounding box with the minimum at (plus!) infinity and maximum at (minus!)
-- infinity acts as a neutral element. This is mostly useful so we can make
-- potentiallly empty data structures such as @[a]@ and @'Maybe' a@ instances of
-- 'HasBoundingBox'.
instance Monoid BoundingBox where
    mempty :: BoundingBox
mempty = Vec2 -> Vec2 -> BoundingBox
BoundingBox (Double -> Double -> Vec2
Vec2 Double
inf Double
inf) (Double -> Double -> Vec2
Vec2 (-Double
inf) (-Double
inf))
      where inf :: Double
inf = Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0

-- | This type simply wraps its contents, but reports its bounding box as 'mempty'.
-- It’s a very useful type when you want to e.g. resize the whole geometry given to
-- your rendering function, but it contains some non-geometrical render data, like
-- a timestamp for each shape.
newtype NoBoundingBox a = NoBoundingBox a
    deriving (NoBoundingBox a -> NoBoundingBox a -> Bool
(NoBoundingBox a -> NoBoundingBox a -> Bool)
-> (NoBoundingBox a -> NoBoundingBox a -> Bool)
-> Eq (NoBoundingBox a)
forall a. Eq a => NoBoundingBox a -> NoBoundingBox a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => NoBoundingBox a -> NoBoundingBox a -> Bool
== :: NoBoundingBox a -> NoBoundingBox a -> Bool
$c/= :: forall a. Eq a => NoBoundingBox a -> NoBoundingBox a -> Bool
/= :: NoBoundingBox a -> NoBoundingBox a -> Bool
Eq, Eq (NoBoundingBox a)
Eq (NoBoundingBox a)
-> (NoBoundingBox a -> NoBoundingBox a -> Ordering)
-> (NoBoundingBox a -> NoBoundingBox a -> Bool)
-> (NoBoundingBox a -> NoBoundingBox a -> Bool)
-> (NoBoundingBox a -> NoBoundingBox a -> Bool)
-> (NoBoundingBox a -> NoBoundingBox a -> Bool)
-> (NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a)
-> (NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a)
-> Ord (NoBoundingBox a)
NoBoundingBox a -> NoBoundingBox a -> Bool
NoBoundingBox a -> NoBoundingBox a -> Ordering
NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (NoBoundingBox a)
forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Bool
forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Ordering
forall a.
Ord a =>
NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
$ccompare :: forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Ordering
compare :: NoBoundingBox a -> NoBoundingBox a -> Ordering
$c< :: forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Bool
< :: NoBoundingBox a -> NoBoundingBox a -> Bool
$c<= :: forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Bool
<= :: NoBoundingBox a -> NoBoundingBox a -> Bool
$c> :: forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Bool
> :: NoBoundingBox a -> NoBoundingBox a -> Bool
$c>= :: forall a. Ord a => NoBoundingBox a -> NoBoundingBox a -> Bool
>= :: NoBoundingBox a -> NoBoundingBox a -> Bool
$cmax :: forall a.
Ord a =>
NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
max :: NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
$cmin :: forall a.
Ord a =>
NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
min :: NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
Ord, Int -> NoBoundingBox a -> ShowS
[NoBoundingBox a] -> ShowS
NoBoundingBox a -> String
(Int -> NoBoundingBox a -> ShowS)
-> (NoBoundingBox a -> String)
-> ([NoBoundingBox a] -> ShowS)
-> Show (NoBoundingBox a)
forall a. Show a => Int -> NoBoundingBox a -> ShowS
forall a. Show a => [NoBoundingBox a] -> ShowS
forall a. Show a => NoBoundingBox a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> NoBoundingBox a -> ShowS
showsPrec :: Int -> NoBoundingBox a -> ShowS
$cshow :: forall a. Show a => NoBoundingBox a -> String
show :: NoBoundingBox a -> String
$cshowList :: forall a. Show a => [NoBoundingBox a] -> ShowS
showList :: [NoBoundingBox a] -> ShowS
Show, ReadPrec [NoBoundingBox a]
ReadPrec (NoBoundingBox a)
Int -> ReadS (NoBoundingBox a)
ReadS [NoBoundingBox a]
(Int -> ReadS (NoBoundingBox a))
-> ReadS [NoBoundingBox a]
-> ReadPrec (NoBoundingBox a)
-> ReadPrec [NoBoundingBox a]
-> Read (NoBoundingBox a)
forall a. Read a => ReadPrec [NoBoundingBox a]
forall a. Read a => ReadPrec (NoBoundingBox a)
forall a. Read a => Int -> ReadS (NoBoundingBox a)
forall a. Read a => ReadS [NoBoundingBox a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (NoBoundingBox a)
readsPrec :: Int -> ReadS (NoBoundingBox a)
$creadList :: forall a. Read a => ReadS [NoBoundingBox a]
readList :: ReadS [NoBoundingBox a]
$creadPrec :: forall a. Read a => ReadPrec (NoBoundingBox a)
readPrec :: ReadPrec (NoBoundingBox a)
$creadListPrec :: forall a. Read a => ReadPrec [NoBoundingBox a]
readListPrec :: ReadPrec [NoBoundingBox a]
Read, NoBoundingBox a
NoBoundingBox a -> NoBoundingBox a -> Bounded (NoBoundingBox a)
forall a. a -> a -> Bounded a
forall a. Bounded a => NoBoundingBox a
$cminBound :: forall a. Bounded a => NoBoundingBox a
minBound :: NoBoundingBox a
$cmaxBound :: forall a. Bounded a => NoBoundingBox a
maxBound :: NoBoundingBox a
Bounded)

instance NFData a => NFData (NoBoundingBox a) where rnf :: NoBoundingBox a -> ()
rnf (NoBoundingBox a
x) = a -> ()
forall a. NFData a => a -> ()
rnf a
x
instance Enum a => Enum (NoBoundingBox a) where
    toEnum :: Int -> NoBoundingBox a
toEnum = a -> NoBoundingBox a
forall a. a -> NoBoundingBox a
NoBoundingBox (a -> NoBoundingBox a) -> (Int -> a) -> Int -> NoBoundingBox a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a. Enum a => Int -> a
toEnum
    fromEnum :: NoBoundingBox a -> Int
fromEnum (NoBoundingBox a
x) = a -> Int
forall a. Enum a => a -> Int
fromEnum a
x
-- | Contents are ignored, reporting an empty bounding box.
instance HasBoundingBox (NoBoundingBox a) where boundingBox :: NoBoundingBox a -> BoundingBox
boundingBox = NoBoundingBox a -> BoundingBox
forall a. Monoid a => a
mempty
instance Semigroup a => Semigroup (NoBoundingBox a) where NoBoundingBox a
x <> :: NoBoundingBox a -> NoBoundingBox a -> NoBoundingBox a
<> NoBoundingBox a
y = a -> NoBoundingBox a
forall a. a -> NoBoundingBox a
NoBoundingBox (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
y)
instance Monoid a => Monoid (NoBoundingBox a) where mempty :: NoBoundingBox a
mempty = a -> NoBoundingBox a
forall a. a -> NoBoundingBox a
NoBoundingBox a
forall a. Monoid a => a
mempty
instance Transform a => Transform (NoBoundingBox a) where transform :: Transformation -> NoBoundingBox a -> NoBoundingBox a
transform Transformation
t (NoBoundingBox a
x) = a -> NoBoundingBox a
forall a. a -> NoBoundingBox a
NoBoundingBox (Transformation -> a -> a
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t a
x)

-- | The rectangle representing a 'BoundingBox', with positive orientation.
--
-- <<docs/haddock/Geometry/Core/boundingBoxPolygon.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/boundingBoxPolygon.svg" 200 200 $ \(Vec2 w h) -> do
--     points <- C.liftIO $ MWC.withRng [] $ \gen -> do
--         let region = shrinkBoundingBox 20 [zero, Vec2 w h]
--         poissonDisc gen region 15 5
--     for_ points $ \p -> sketch (Circle p 3) >> C.fill
--     setColor (mma 1)
--     sketch (boundingBoxPolygon points) >> C.setLineWidth 3 >> C.stroke
-- :}
-- Generated file: size 25KB, crc32: 0x40902165
boundingBoxPolygon :: HasBoundingBox object => object -> Polygon
boundingBoxPolygon :: forall object. HasBoundingBox object => object -> Polygon
boundingBoxPolygon object
object = [Vec2] -> Polygon
Polygon [Double -> Double -> Vec2
Vec2 Double
x1 Double
y1, Double -> Double -> Vec2
Vec2 Double
x2 Double
y1, Double -> Double -> Vec2
Vec2 Double
x2 Double
y2, Double -> Double -> Vec2
Vec2 Double
x1 Double
y2]
  where BoundingBox (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2) = object -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox object
object

-- $
-- >>> polygonOrientation (boundingBoxPolygon [zero, Vec2 10 10])
-- PolygonPositive

-- | Is the argument’s bounding box fully contained in another’s bounding box?
--
-- <<docs/haddock/Geometry/Core/insideBoundingBox.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/insideBoundingBox.svg" 200 200 $ \(Vec2 w h) -> do
--     let parentBB = shrinkBoundingBox 50 [zero, Vec2 w h]
--         paintCheck :: (HasBoundingBox object, Sketch object) => object -> C.Render ()
--         paintCheck object = do
--             when (not (object `insideBoundingBox` parentBB)) $ grouped (C.paintWithAlpha 0.2) $ do
--                 setColor (mma 3)
--                 sketch (boundingBox object)
--                 C.stroke
--             sketch object
--             C.stroke
--     cairoScope $ C.setLineWidth 3 >> setColor (mma 3) >> sketch (boundingBoxPolygon parentBB) >> C.stroke
--     setColor (mma 0) >> paintCheck (Circle (Vec2 110 60) 20)
--     setColor (mma 1) >> paintCheck (Circle (Vec2 80 110) 15)
--     setColor (mma 2) >> paintCheck (Line (Vec2 20 40) (Vec2 60 90))
--     setColor (mma 4) >> paintCheck (transform (translate (Vec2 130 130) <> scale 30) (Geometry.Shapes.regularPolygon 5))
-- :}
-- Generated file: size 5KB, crc32: 0x8c351375
insideBoundingBox :: (HasBoundingBox thing, HasBoundingBox bigObject) => thing -> bigObject -> Bool
insideBoundingBox :: forall thing bigObject.
(HasBoundingBox thing, HasBoundingBox bigObject) =>
thing -> bigObject -> Bool
insideBoundingBox thing
thing bigObject
bigObject =
    let thingBB :: BoundingBox
thingBB = thing -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox thing
thing
        bigObjectBB :: BoundingBox
bigObjectBB = bigObject -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox bigObject
bigObject
    in BoundingBox
bigObjectBB BoundingBox -> BoundingBox -> Bool
forall a. Eq a => a -> a -> Bool
== BoundingBox
bigObjectBB BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> BoundingBox
thingBB

-- | Center\/mean\/centroid of a bounding box.
--
-- <<docs/haddock/Geometry/Core/boundingBoxCenter.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/boundingBoxCenter.svg" 200 200 $ \(Vec2 w h) -> do
--     points <- C.liftIO $ MWC.withRng [] $ \gen -> do
--         let region = shrinkBoundingBox 20 [zero, Vec2 w h]
--         poissonDisc gen region 15 5
--     let pointsBB = boundingBox points
--     for_ points $ \p -> sketch (Circle p 3) >> C.fill
--     setColor (mma 1)
--     sketch (boundingBoxPolygon pointsBB)
--     sketch (Cross (boundingBoxCenter pointsBB) 10)
--     sketch (Circle (boundingBoxCenter pointsBB) 10)
--     C.stroke
-- :}
-- Generated file: size 25KB, crc32: 0x31972ee1
boundingBoxCenter :: HasBoundingBox a => a -> Vec2
boundingBoxCenter :: forall a. HasBoundingBox a => a -> Vec2
boundingBoxCenter a
x = let BoundingBox Vec2
lo Vec2
hi = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
x in (Vec2
loVec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+.Vec2
hi)Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/.Double
2

-- | Bounding box of the intersection of two bounding boxes. This is the
-- intersection analogon to '<>' representing union.
--
-- <<docs/haddock/Geometry/Core/boundingBoxIntersection.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/boundingBoxIntersection.svg" 200 200 $ \(Vec2 w h) -> do
--     (p1s, p2s) <- C.liftIO $ MWC.withRng [] $ \gen -> do
--         let region1 = shrinkBoundingBox 20 [zero, Vec2 150 150]
--         p1s <- poissonDisc gen region1 15 5
--         let region2 = shrinkBoundingBox 20 [Vec2 50 50, Vec2 200 200]
--         p2s <- poissonDisc gen region2 15 5
--         pure (p1s, p2s)
--     for_ p1s $ \p -> sketch (Circle p 3) >> setColor (mma 0) >> C.fill
--     for_ p2s $ \p -> sketch (Circle p 3) >> setColor (mma 1) >> C.fill
--     sketch (fmap boundingBoxPolygon (boundingBoxIntersection p1s p2s)) >> setColor (mma 3) >> C.stroke
-- :}
-- Generated file: size 25KB, crc32: 0x72cfba9f
boundingBoxIntersection
    :: (HasBoundingBox a, HasBoundingBox b)
    => a
    -> b
    -> Maybe BoundingBox -- ^ 'Nothing' if the input boxes don’t have finite overlap.
boundingBoxIntersection :: forall a b.
(HasBoundingBox a, HasBoundingBox b) =>
a -> b -> Maybe BoundingBox
boundingBoxIntersection a
a b
b =
    let BoundingBox (Vec2 Double
aMinX Double
aMinY) (Vec2 Double
aMaxX Double
aMaxY) = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
a
        BoundingBox (Vec2 Double
bMinX Double
bMinY) (Vec2 Double
bMaxX Double
bMaxY) = b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b
b

        minX :: Double
minX = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
aMinX Double
bMinX
        minY :: Double
minY = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
aMinY Double
bMinY

        maxX :: Double
maxX = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
aMaxX Double
bMaxX
        maxY :: Double
maxY = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
aMaxY Double
bMaxY

    in if
        | Double
minX Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
maxX -> Maybe BoundingBox
forall a. Maybe a
Nothing
        | Double
minY Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
maxY -> Maybe BoundingBox
forall a. Maybe a
Nothing
        | Bool
otherwise -> BoundingBox -> Maybe BoundingBox
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> BoundingBox
BoundingBox (Double -> Double -> Vec2
Vec2 Double
minX Double
minY) (Double -> Double -> Vec2
Vec2 Double
maxX Double
maxY))

-- | Width and height of a 'BoundingBox'.
--
-- <<docs/haddock/Geometry/Core/boundingBoxSize.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/boundingBoxSize.svg" 300 200 $ \wh -> do
--     let bb = shrinkBoundingBox 20 [zero, wh]
--         (bbWidth, bbHeight) = boundingBoxSize bb
--     cairoScope $ do
--         setColor (mma 0)
--         sketch (boundingBoxPolygon bb)
--         C.stroke
--     let BoundingBox (Vec2 minX minY) (Vec2 maxX maxY) = shrinkBoundingBox 7 bb
--         arrowBodyX = resizeLineSymmetric (\l -> l-5) (Line (Vec2 minX minY) (Vec2 maxX minY))
--         arrowBodyY = resizeLineSymmetric (\l -> l-5) (Line (Vec2 minX maxY) (Vec2 minX minY))
--     let style = def { _arrowheadSize = 7 }
--     cairoScope $ do
--         setColor (mma 1)
--         cairoScope $ do
--             sketch (Arrow arrowBodyX style)
--             sketch (Arrow (lineReverse arrowBodyX) style {_arrowDrawBody = False})
--             C.stroke
--         cairoScope $ do
--             let Line start end = arrowBodyX
--                 Line _ textGoesHere = resizeLine (const 5) (perpendicularBisector arrowBodyX)
--             let textOpts = PlotTextOptions
--                     { _textStartingPoint = textGoesHere
--                     , _textHeight = 10
--                     , _textHAlign = HCenter
--                     , _textVAlign = VBottom
--                     }
--             for_ (plotText textOpts (printf "width: %.f px" bbWidth)) sketch
--             C.stroke
--     cairoScope $ do
--         setColor (mma 3)
--         cairoScope $ do
--             sketch (Arrow arrowBodyY style)
--             sketch (Arrow (lineReverse arrowBodyY) style {_arrowDrawBody = False})
--             C.stroke
--         cairoScope $ do
--             let Line start end = arrowBodyY
--                 Line _ textGoesHere = resizeLine (const 5) (perpendicularBisector arrowBodyY)
--             let textOpts = PlotTextOptions
--                     { _textStartingPoint = textGoesHere
--                     , _textHeight = 10
--                     , _textHAlign = HLeft
--                     , _textVAlign = VCenter
--                     }
--             for_ (plotText textOpts (printf "height: %.f px" bbHeight)) sketch
--             C.stroke
-- :}
-- Generated file: size 9KB, crc32: 0x1ff78b56
boundingBoxSize :: HasBoundingBox a => a -> (Double, Double)
boundingBoxSize :: forall a. HasBoundingBox a => a -> (Double, Double)
boundingBoxSize a
x = (Double -> Double
forall a. Num a => a -> a
abs Double
deltaX, Double -> Double
forall a. Num a => a -> a
abs Double
deltaY)
  where
    BoundingBox Vec2
lo Vec2
hi = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
x
    Vec2 Double
deltaX Double
deltaY = Vec2
hi Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
lo

-- | Grow the bounding box by moving all its bounds outwards by a specified amount.
-- Useful to introduce margins. Negative values shrink instead; 'shrinkBoundingBox'
-- is a convenience wrapper for this case.
--
-- <<docs/haddock/Geometry/Core/growBoundingBox.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/growBoundingBox.svg" 200 200 $ \(Vec2 w h) -> do
--     let bb = shrinkBoundingBox 40 [zero, Vec2 w h]
--     for_ [0,5..25] $ \amount -> cairoScope $ do
--         when (amount == 0) (C.setLineWidth 3)
--         sketch (boundingBoxPolygon (growBoundingBox (fromIntegral amount) bb))
--         setColor (icefire (Numerics.Interpolation.lerp (0,25) (0.5, 1) (fromIntegral amount)))
--         C.stroke
-- :}
-- Generated file: size 4KB, crc32: 0xedcda2c4
growBoundingBox
    :: HasBoundingBox boundingBox
    => Double -- ^ Amount \(x\) to move each side. Note that e.g. the total width will increase by \(2\times x\).
    -> boundingBox
    -> BoundingBox
growBoundingBox :: forall boundingBox.
HasBoundingBox boundingBox =>
Double -> boundingBox -> BoundingBox
growBoundingBox Double
delta boundingBox
stuff  =
    let margin :: Vec2
margin = Double -> Double -> Vec2
Vec2 Double
delta Double
delta
        BoundingBox Vec2
lo Vec2
hi = boundingBox -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox boundingBox
stuff
    in [Vec2] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox [Vec2
lo Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
margin, Vec2
hi Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
margin]

-- | Convenience function for 'growBoundingBox' with a negative amount.
--
-- <<docs/haddock/Geometry/Core/shrinkBoundingBox.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/shrinkBoundingBox.svg" 200 200 $ \(Vec2 w h) -> do
--     let bb = shrinkBoundingBox 40 [zero, Vec2 w h]
--     for_ [0,5..25] $ \amount -> cairoScope $ do
--         when (amount == 0) (C.setLineWidth 3)
--         sketch (boundingBoxPolygon (shrinkBoundingBox (fromIntegral amount) bb))
--         setColor (icefire (Numerics.Interpolation.lerp (0,25) (0.5, 0) (fromIntegral amount)))
--         C.stroke
-- :}
-- Generated file: size 4KB, crc32: 0xe0236688
shrinkBoundingBox :: HasBoundingBox boundingBox => Double -> boundingBox -> BoundingBox
shrinkBoundingBox :: forall boundingBox.
HasBoundingBox boundingBox =>
Double -> boundingBox -> BoundingBox
shrinkBoundingBox Double
delta = Double -> boundingBox -> BoundingBox
forall boundingBox.
HasBoundingBox boundingBox =>
Double -> boundingBox -> BoundingBox
growBoundingBox (-Double
delta)

-- | Anything we can paint has a bounding box. Knowing it is useful to e.g. rescale
-- the geometry to fit into the canvas or for collision detection.
class HasBoundingBox a where
    boundingBox :: a -> BoundingBox

-- | This is simply 'id', so a bounding box that doesn’t satisfy the min/max invariant will remain incorrect.
instance HasBoundingBox BoundingBox where
    boundingBox :: BoundingBox -> BoundingBox
boundingBox = BoundingBox -> BoundingBox
forall a. a -> a
id

instance HasBoundingBox Vec2 where
    boundingBox :: Vec2 -> BoundingBox
boundingBox Vec2
v = Vec2 -> Vec2 -> BoundingBox
BoundingBox Vec2
v Vec2
v

instance HasBoundingBox a => HasBoundingBox (Maybe a) where
    boundingBox :: Maybe a -> BoundingBox
boundingBox = (a -> BoundingBox) -> Maybe a -> BoundingBox
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox

instance (HasBoundingBox a, HasBoundingBox b) => HasBoundingBox (Either a b) where
    boundingBox :: Either a b -> BoundingBox
boundingBox = (a -> BoundingBox)
-> (b -> BoundingBox) -> Either a b -> BoundingBox
forall m a b. Monoid m => (a -> m) -> (b -> m) -> Either a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox

instance (HasBoundingBox a, HasBoundingBox b) => HasBoundingBox (a,b) where
    boundingBox :: (a, b) -> BoundingBox
boundingBox (a
a,b
b) = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
a BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b
b

instance (HasBoundingBox a, HasBoundingBox b, HasBoundingBox c) => HasBoundingBox (a,b,c) where
    boundingBox :: (a, b, c) -> BoundingBox
boundingBox (a
a,b
b,c
c) = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
a BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b
b BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> c -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox c
c

instance (HasBoundingBox a, HasBoundingBox b, HasBoundingBox c, HasBoundingBox d) => HasBoundingBox (a,b,c,d) where
    boundingBox :: (a, b, c, d) -> BoundingBox
boundingBox (a
a,b
b,c
c,d
d) = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
a BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b
b BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> c -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox c
c BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> d -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox d
d

instance (HasBoundingBox a, HasBoundingBox b, HasBoundingBox c, HasBoundingBox d, HasBoundingBox e) => HasBoundingBox (a,b,c,d,e) where
    boundingBox :: (a, b, c, d, e) -> BoundingBox
boundingBox (a
a,b
b,c
c,d
d,e
e) = a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
a BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b
b BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> c -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox c
c BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> d -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox d
d BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> e -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox e
e

instance (HasBoundingBox a) => HasBoundingBox [a] where
    boundingBox :: [a] -> BoundingBox
boundingBox = (a -> BoundingBox) -> [a] -> BoundingBox
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox

instance (HasBoundingBox a) => HasBoundingBox (Vector a) where
    boundingBox :: Vector a -> BoundingBox
boundingBox = (a -> BoundingBox) -> Vector a -> BoundingBox
forall m a. Monoid m => (a -> m) -> Vector a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox

instance (HasBoundingBox a) => HasBoundingBox (S.Set a) where
    boundingBox :: Set a -> BoundingBox
boundingBox = (a -> BoundingBox) -> Set a -> BoundingBox
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox

instance (HasBoundingBox a) => HasBoundingBox (M.Map k a) where
    boundingBox :: Map k a -> BoundingBox
boundingBox = (a -> BoundingBox) -> Map k a -> BoundingBox
forall m a. Monoid m => (a -> m) -> Map k a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox

-- | <<docs/haddock/Geometry/Core/bounding_box_line.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/bounding_box_line.svg" 150 100 $ \_ -> do
--     let line = Line (Vec2 10 10) (Vec2 140 90)
--     cairoScope $ do
--         setColor (mma 1)
--         C.setDash [1.5,3] 0
--         sketch (boundingBox line)
--         C.stroke
--     cairoScope $ do
--         C.setLineWidth 2
--         sketch line
--         C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0xd5f4f645
instance HasBoundingBox Line where
    boundingBox :: Line -> BoundingBox
boundingBox (Line Vec2
start Vec2
end) = (Vec2, Vec2) -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox (Vec2
start, Vec2
end)

instance HasBoundingBox Polygon where
    boundingBox :: Polygon -> BoundingBox
boundingBox (Polygon [Vec2]
ps) = [Vec2] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox [Vec2]
ps

-- | <<docs/haddock/Geometry/Core/bounding_box_polyline.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/bounding_box_polyline.svg" 150 100 $ \_ -> do
--     let polyline = Polyline [Vec2 10 10, Vec2 90 90, Vec2 120 10, Vec2 140 50]
--     cairoScope $ do
--         setColor (mma 1)
--         C.setDash [1.5,3] 0
--         sketch (boundingBox polyline)
--         C.stroke
--     cairoScope $ do
--         C.setLineWidth 2
--         sketch polyline
--         C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0xd45fc8b5
instance HasBoundingBox Polyline where boundingBox :: Polyline -> BoundingBox
boundingBox (Polyline [Vec2]
xs) = [Vec2] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox [Vec2]
xs

-- | Do the bounding boxes of two objects overlap?
overlappingBoundingBoxes :: (HasBoundingBox a, HasBoundingBox b) => a -> b -> Bool
overlappingBoundingBoxes :: forall thing bigObject.
(HasBoundingBox thing, HasBoundingBox bigObject) =>
thing -> bigObject -> Bool
overlappingBoundingBoxes a
a b
b = BoundingBox -> BoundingBox -> Bool
go (a -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox a
a) (b -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox b
b)
  where
    go :: BoundingBox -> BoundingBox -> Bool
go (BoundingBox (Vec2 Double
loAx Double
loAy) (Vec2 Double
hiAx Double
hiAy)) (BoundingBox (Vec2 Double
loBx Double
loBy) (Vec2 Double
hiBx Double
hiBy))
        | Double
loAx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
hiBx = Bool
False -- A right of B
        | Double
hiAx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
loBx = Bool
False -- A left of B
        | Double
loAy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
hiBy = Bool
False -- A below B
        | Double
hiAy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
loBy = Bool
False -- A above B
        | Bool
otherwise = Bool
True

data FitDimension
    = FitWidthHeight -- ^ Fit both width and height
    | FitWidth       -- ^ Fit width, ignoring what happens to the height (allow y stretching/compression)
    | FitHeight      -- ^ Fit height, ignoring what happens to the width  (allow x stretching/compression)
    | FitNone        -- ^ Don't fit dimensions, only align
    deriving (FitDimension -> FitDimension -> Bool
(FitDimension -> FitDimension -> Bool)
-> (FitDimension -> FitDimension -> Bool) -> Eq FitDimension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FitDimension -> FitDimension -> Bool
== :: FitDimension -> FitDimension -> Bool
$c/= :: FitDimension -> FitDimension -> Bool
/= :: FitDimension -> FitDimension -> Bool
Eq, Eq FitDimension
Eq FitDimension
-> (FitDimension -> FitDimension -> Ordering)
-> (FitDimension -> FitDimension -> Bool)
-> (FitDimension -> FitDimension -> Bool)
-> (FitDimension -> FitDimension -> Bool)
-> (FitDimension -> FitDimension -> Bool)
-> (FitDimension -> FitDimension -> FitDimension)
-> (FitDimension -> FitDimension -> FitDimension)
-> Ord FitDimension
FitDimension -> FitDimension -> Bool
FitDimension -> FitDimension -> Ordering
FitDimension -> FitDimension -> FitDimension
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FitDimension -> FitDimension -> Ordering
compare :: FitDimension -> FitDimension -> Ordering
$c< :: FitDimension -> FitDimension -> Bool
< :: FitDimension -> FitDimension -> Bool
$c<= :: FitDimension -> FitDimension -> Bool
<= :: FitDimension -> FitDimension -> Bool
$c> :: FitDimension -> FitDimension -> Bool
> :: FitDimension -> FitDimension -> Bool
$c>= :: FitDimension -> FitDimension -> Bool
>= :: FitDimension -> FitDimension -> Bool
$cmax :: FitDimension -> FitDimension -> FitDimension
max :: FitDimension -> FitDimension -> FitDimension
$cmin :: FitDimension -> FitDimension -> FitDimension
min :: FitDimension -> FitDimension -> FitDimension
Ord, Int -> FitDimension -> ShowS
[FitDimension] -> ShowS
FitDimension -> String
(Int -> FitDimension -> ShowS)
-> (FitDimension -> String)
-> ([FitDimension] -> ShowS)
-> Show FitDimension
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FitDimension -> ShowS
showsPrec :: Int -> FitDimension -> ShowS
$cshow :: FitDimension -> String
show :: FitDimension -> String
$cshowList :: [FitDimension] -> ShowS
showList :: [FitDimension] -> ShowS
Show)

data FitAspect
    = MaintainAspect -- ^ Maintain width:height aspect ratio
    | IgnoreAspect   -- ^ Ignore aspect ratio
    deriving (FitAspect -> FitAspect -> Bool
(FitAspect -> FitAspect -> Bool)
-> (FitAspect -> FitAspect -> Bool) -> Eq FitAspect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FitAspect -> FitAspect -> Bool
== :: FitAspect -> FitAspect -> Bool
$c/= :: FitAspect -> FitAspect -> Bool
/= :: FitAspect -> FitAspect -> Bool
Eq, Eq FitAspect
Eq FitAspect
-> (FitAspect -> FitAspect -> Ordering)
-> (FitAspect -> FitAspect -> Bool)
-> (FitAspect -> FitAspect -> Bool)
-> (FitAspect -> FitAspect -> Bool)
-> (FitAspect -> FitAspect -> Bool)
-> (FitAspect -> FitAspect -> FitAspect)
-> (FitAspect -> FitAspect -> FitAspect)
-> Ord FitAspect
FitAspect -> FitAspect -> Bool
FitAspect -> FitAspect -> Ordering
FitAspect -> FitAspect -> FitAspect
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FitAspect -> FitAspect -> Ordering
compare :: FitAspect -> FitAspect -> Ordering
$c< :: FitAspect -> FitAspect -> Bool
< :: FitAspect -> FitAspect -> Bool
$c<= :: FitAspect -> FitAspect -> Bool
<= :: FitAspect -> FitAspect -> Bool
$c> :: FitAspect -> FitAspect -> Bool
> :: FitAspect -> FitAspect -> Bool
$c>= :: FitAspect -> FitAspect -> Bool
>= :: FitAspect -> FitAspect -> Bool
$cmax :: FitAspect -> FitAspect -> FitAspect
max :: FitAspect -> FitAspect -> FitAspect
$cmin :: FitAspect -> FitAspect -> FitAspect
min :: FitAspect -> FitAspect -> FitAspect
Ord, Int -> FitAspect -> ShowS
[FitAspect] -> ShowS
FitAspect -> String
(Int -> FitAspect -> ShowS)
-> (FitAspect -> String)
-> ([FitAspect] -> ShowS)
-> Show FitAspect
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FitAspect -> ShowS
showsPrec :: Int -> FitAspect -> ShowS
$cshow :: FitAspect -> String
show :: FitAspect -> String
$cshowList :: [FitAspect] -> ShowS
showList :: [FitAspect] -> ShowS
Show)

data FitAlign
    = FitAlignCenter      -- ^ Align the centers of the results
    | FitAlignTopLeft     -- ^ Align the top left of the results
    | FitAlignTopRight    -- ^ Align the top right of the results
    | FitAlignBottomLeft  -- ^ Align the bottom left of the results
    | FitAlignBottomRight -- ^ Align the bottom right of the results
    deriving (FitAlign -> FitAlign -> Bool
(FitAlign -> FitAlign -> Bool)
-> (FitAlign -> FitAlign -> Bool) -> Eq FitAlign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FitAlign -> FitAlign -> Bool
== :: FitAlign -> FitAlign -> Bool
$c/= :: FitAlign -> FitAlign -> Bool
/= :: FitAlign -> FitAlign -> Bool
Eq, Eq FitAlign
Eq FitAlign
-> (FitAlign -> FitAlign -> Ordering)
-> (FitAlign -> FitAlign -> Bool)
-> (FitAlign -> FitAlign -> Bool)
-> (FitAlign -> FitAlign -> Bool)
-> (FitAlign -> FitAlign -> Bool)
-> (FitAlign -> FitAlign -> FitAlign)
-> (FitAlign -> FitAlign -> FitAlign)
-> Ord FitAlign
FitAlign -> FitAlign -> Bool
FitAlign -> FitAlign -> Ordering
FitAlign -> FitAlign -> FitAlign
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FitAlign -> FitAlign -> Ordering
compare :: FitAlign -> FitAlign -> Ordering
$c< :: FitAlign -> FitAlign -> Bool
< :: FitAlign -> FitAlign -> Bool
$c<= :: FitAlign -> FitAlign -> Bool
<= :: FitAlign -> FitAlign -> Bool
$c> :: FitAlign -> FitAlign -> Bool
> :: FitAlign -> FitAlign -> Bool
$c>= :: FitAlign -> FitAlign -> Bool
>= :: FitAlign -> FitAlign -> Bool
$cmax :: FitAlign -> FitAlign -> FitAlign
max :: FitAlign -> FitAlign -> FitAlign
$cmin :: FitAlign -> FitAlign -> FitAlign
min :: FitAlign -> FitAlign -> FitAlign
Ord, Int -> FitAlign -> ShowS
[FitAlign] -> ShowS
FitAlign -> String
(Int -> FitAlign -> ShowS)
-> (FitAlign -> String) -> ([FitAlign] -> ShowS) -> Show FitAlign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FitAlign -> ShowS
showsPrec :: Int -> FitAlign -> ShowS
$cshow :: FitAlign -> String
show :: FitAlign -> String
$cshowList :: [FitAlign] -> ShowS
showList :: [FitAlign] -> ShowS
Show)

-- | 'transformBoundingBox' settings paramter. If you don’t care for the details, use 'def'.
data TransformBBSettings = TransformBBSettings
    { TransformBBSettings -> FitDimension
_bbFitDimension :: FitDimension
    , TransformBBSettings -> FitAspect
_bbFitAspect    :: FitAspect
    , TransformBBSettings -> FitAlign
_bbFitAlign     :: FitAlign
    } deriving (TransformBBSettings -> TransformBBSettings -> Bool
(TransformBBSettings -> TransformBBSettings -> Bool)
-> (TransformBBSettings -> TransformBBSettings -> Bool)
-> Eq TransformBBSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransformBBSettings -> TransformBBSettings -> Bool
== :: TransformBBSettings -> TransformBBSettings -> Bool
$c/= :: TransformBBSettings -> TransformBBSettings -> Bool
/= :: TransformBBSettings -> TransformBBSettings -> Bool
Eq, Eq TransformBBSettings
Eq TransformBBSettings
-> (TransformBBSettings -> TransformBBSettings -> Ordering)
-> (TransformBBSettings -> TransformBBSettings -> Bool)
-> (TransformBBSettings -> TransformBBSettings -> Bool)
-> (TransformBBSettings -> TransformBBSettings -> Bool)
-> (TransformBBSettings -> TransformBBSettings -> Bool)
-> (TransformBBSettings
    -> TransformBBSettings -> TransformBBSettings)
-> (TransformBBSettings
    -> TransformBBSettings -> TransformBBSettings)
-> Ord TransformBBSettings
TransformBBSettings -> TransformBBSettings -> Bool
TransformBBSettings -> TransformBBSettings -> Ordering
TransformBBSettings -> TransformBBSettings -> TransformBBSettings
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TransformBBSettings -> TransformBBSettings -> Ordering
compare :: TransformBBSettings -> TransformBBSettings -> Ordering
$c< :: TransformBBSettings -> TransformBBSettings -> Bool
< :: TransformBBSettings -> TransformBBSettings -> Bool
$c<= :: TransformBBSettings -> TransformBBSettings -> Bool
<= :: TransformBBSettings -> TransformBBSettings -> Bool
$c> :: TransformBBSettings -> TransformBBSettings -> Bool
> :: TransformBBSettings -> TransformBBSettings -> Bool
$c>= :: TransformBBSettings -> TransformBBSettings -> Bool
>= :: TransformBBSettings -> TransformBBSettings -> Bool
$cmax :: TransformBBSettings -> TransformBBSettings -> TransformBBSettings
max :: TransformBBSettings -> TransformBBSettings -> TransformBBSettings
$cmin :: TransformBBSettings -> TransformBBSettings -> TransformBBSettings
min :: TransformBBSettings -> TransformBBSettings -> TransformBBSettings
Ord, Int -> TransformBBSettings -> ShowS
[TransformBBSettings] -> ShowS
TransformBBSettings -> String
(Int -> TransformBBSettings -> ShowS)
-> (TransformBBSettings -> String)
-> ([TransformBBSettings] -> ShowS)
-> Show TransformBBSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransformBBSettings -> ShowS
showsPrec :: Int -> TransformBBSettings -> ShowS
$cshow :: TransformBBSettings -> String
show :: TransformBBSettings -> String
$cshowList :: [TransformBBSettings] -> ShowS
showList :: [TransformBBSettings] -> ShowS
Show)

-- | Fit width+height, maintaining aspect ratio, and matching centers.
instance Default TransformBBSettings where
    def :: TransformBBSettings
def = FitDimension -> FitAspect -> FitAlign -> TransformBBSettings
TransformBBSettings FitDimension
FitWidthHeight FitAspect
MaintainAspect FitAlign
FitAlignCenter

-- | Generate a transformation that transforms the bounding box of one object to
-- match the other’s. Canonical use case: transform any part of your graphic to
-- fill the Cairo canvas.
transformBoundingBox
    :: (HasBoundingBox source, HasBoundingBox target)
    => source -- ^ e.g. drawing coordinate system
    -> target -- ^ e.g. Cairo canvas
    -> TransformBBSettings
    -> Transformation
transformBoundingBox :: forall source target.
(HasBoundingBox source, HasBoundingBox target) =>
source -> target -> TransformBBSettings -> Transformation
transformBoundingBox source
source target
target (TransformBBSettings FitDimension
fitDimension FitAspect
fitAspect FitAlign
fitAlign)
  = let bbSource :: BoundingBox
bbSource@(BoundingBox Vec2
sourceTopLeft Vec2
sourceBottomRight) = source -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox source
source
        bbTarget :: BoundingBox
bbTarget@(BoundingBox Vec2
targetTopLeft Vec2
targetBottomRight) = target -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox target
target

        sourceCenter :: Vec2
sourceCenter = BoundingBox -> Vec2
forall a. HasBoundingBox a => a -> Vec2
boundingBoxCenter BoundingBox
bbSource
        targetCenter :: Vec2
targetCenter = BoundingBox -> Vec2
forall a. HasBoundingBox a => a -> Vec2
boundingBoxCenter BoundingBox
bbTarget

        sourceBottomLeft :: Vec2
sourceBottomLeft =
            let Vec2 Double
x Double
_ = Vec2
sourceTopLeft
                Vec2 Double
_ Double
y = Vec2
sourceBottomRight
            in Double -> Double -> Vec2
Vec2 Double
x Double
y
        targetBottomLeft :: Vec2
targetBottomLeft =
            let Vec2 Double
x Double
_ = Vec2
targetTopLeft
                Vec2 Double
_ Double
y = Vec2
targetBottomRight
            in Double -> Double -> Vec2
Vec2 Double
x Double
y
        sourceTopRight :: Vec2
sourceTopRight =
            let Vec2 Double
x Double
_ = Vec2
sourceBottomRight
                Vec2 Double
_ Double
y = Vec2
sourceTopLeft
            in Double -> Double -> Vec2
Vec2 Double
x Double
y
        targetTopRight :: Vec2
targetTopRight =
            let Vec2 Double
x Double
_ = Vec2
targetBottomRight
                Vec2 Double
_ Double
y = Vec2
targetTopLeft
            in Double -> Double -> Vec2
Vec2 Double
x Double
y

        (Vec2
scalePivot, Vec2
translationOffset) = case FitAlign
fitAlign of
            FitAlign
FitAlignCenter      -> (Vec2
targetCenter,      Vec2
targetCenter      Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
sourceCenter)
            FitAlign
FitAlignTopLeft     -> (Vec2
targetTopLeft,     Vec2
targetTopLeft     Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
sourceTopLeft)
            FitAlign
FitAlignTopRight    -> (Vec2
targetTopRight,    Vec2
targetTopRight    Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
sourceTopRight)
            FitAlign
FitAlignBottomLeft  -> (Vec2
targetBottomLeft,  Vec2
targetBottomLeft  Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
sourceBottomLeft)
            FitAlign
FitAlignBottomRight -> (Vec2
targetBottomRight, Vec2
targetBottomRight Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
sourceBottomRight)

        (Double
sourceWidth, Double
sourceHeight) = BoundingBox -> (Double, Double)
forall a. HasBoundingBox a => a -> (Double, Double)
boundingBoxSize BoundingBox
bbSource
        (Double
targetWidth, Double
targetHeight) = BoundingBox -> (Double, Double)
forall a. HasBoundingBox a => a -> (Double, Double)
boundingBoxSize BoundingBox
bbTarget
        xScaleFactor :: Double
xScaleFactor = Double
targetWidth Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
sourceWidth
        yScaleFactor :: Double
yScaleFactor = Double
targetHeight Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
sourceHeight

        scaleToMatchSize :: Transformation
scaleToMatchSize = case (FitDimension
fitDimension, FitAspect
fitAspect) of
            (FitDimension
FitWidthHeight, FitAspect
MaintainAspect) -> let scaleFactor :: Double
scaleFactor = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
xScaleFactor Double
yScaleFactor in Vec2 -> Double -> Transformation
scaleAround Vec2
scalePivot Double
scaleFactor
            (FitDimension
FitWidth,       FitAspect
MaintainAspect) -> Vec2 -> Double -> Transformation
scaleAround Vec2
scalePivot Double
xScaleFactor
            (FitDimension
FitHeight,      FitAspect
MaintainAspect) -> Vec2 -> Double -> Transformation
scaleAround Vec2
scalePivot Double
yScaleFactor
            (FitDimension
FitWidthHeight, FitAspect
IgnoreAspect) -> Vec2 -> Double -> Double -> Transformation
scaleAround' Vec2
scalePivot Double
xScaleFactor Double
yScaleFactor
            (FitDimension
FitWidth,       FitAspect
IgnoreAspect) -> Vec2 -> Double -> Double -> Transformation
scaleAround' Vec2
scalePivot Double
xScaleFactor Double
1
            (FitDimension
FitHeight,      FitAspect
IgnoreAspect) -> Vec2 -> Double -> Double -> Transformation
scaleAround' Vec2
scalePivot Double
1 Double
yScaleFactor
            (FitDimension
FitNone,        FitAspect
_)            -> Transformation
forall a. Monoid a => a
mempty

    in Transformation
scaleToMatchSize Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Vec2 -> Transformation
translate Vec2
translationOffset

instance VectorSpace Vec2 where
    Vec2 Double
x1 Double
y1 +. :: Vec2 -> Vec2 -> Vec2
+. Vec2 Double
x2 Double
y2 = Double -> Double -> Vec2
Vec2 (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
x2) (Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
y2)
    Vec2 Double
x1 Double
y1 -. :: Vec2 -> Vec2 -> Vec2
-. Vec2 Double
x2 Double
y2 = Double -> Double -> Vec2
Vec2 (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x2) (Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y2)
    Double
a *. :: Double -> Vec2 -> Vec2
*. Vec2 Double
x Double
y = Double -> Double -> Vec2
Vec2 (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x) (Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y)
    Vec2 Double
x Double
y /. :: Vec2 -> Double -> Vec2
/. Double
a = Double -> Double -> Vec2
Vec2 (Double
xDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
a) (Double
yDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
a)
    negateV :: Vec2 -> Vec2
negateV (Vec2 Double
x Double
y) = Double -> Double -> Vec2
Vec2 (-Double
x) (-Double
y)
    zero :: Vec2
zero = Double -> Double -> Vec2
Vec2 Double
0 Double
0

-- | Dot product.
--
-- \[ \begin{pmatrix}a \\ b\end{pmatrix} \cdot \begin{pmatrix}x \\ y\end{pmatrix}\ = ax + by\]
--
-- Can be used to check whether two vectors point into the same direction (product > 0).
dotProduct :: Vec2 -> Vec2 -> Double
dotProduct :: Vec2 -> Vec2 -> Double
dotProduct (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2) = Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y2

-- | Euclidean norm.
--
-- \[ \|\mathbf v\| = \sqrt{v_x^2 + v_y^2} \]
norm :: Vec2 -> Double
norm :: Vec2 -> Double
norm = Double -> Double
forall a. Floating a => a -> a
sqrt (Double -> Double) -> (Vec2 -> Double) -> Vec2 -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec2 -> Double
normSquare

-- | Squared Euclidean norm. Does not require a square root, and is thus
-- suitable for sorting points by distance without excluding certain kinds of
-- numbers such as rationals.
--
-- \[ \|\mathbf v\|^2 = v_x^2 + v_y^2 \]
normSquare :: Vec2 -> Double
normSquare :: Vec2 -> Double
normSquare Vec2
v = Vec2 -> Vec2 -> Double
dotProduct Vec2
v Vec2
v

-- | Construct a 'Vec2' from polar coordinates.
--
-- <<docs/haddock/Geometry/Core/polar.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/polar.svg" 100 60 $ \_ -> do
--     let angle = deg 30
--         p = polar angle 100
--     cairoScope $ do
--         setColor (mma 1)
--         C.arc 0 0 40 0 (getRad angle)
--         sketch (Line zero p)
--         C.stroke
--     cairoScope $ do
--         setColor (mma 0)
--         sketch (Circle p 3)
--         C.fill
-- :}
-- Generated file: size 2KB, crc32: 0x7a43a888
polar :: Angle -> Double -> Vec2
polar :: Angle -> Double -> Vec2
polar (Rad Double
a) Double
d = Double -> Double -> Vec2
Vec2 (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
a) (Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
a)

-- | Newtype safety wrapper.
--
-- Angles are not 'Ord', since the cyclic structure is very error-prone when
-- combined with comparisons and 'VectorSpace' arithmetic in practice :-( Often
-- times, using the 'dotProduct' (measure same-direction-ness) or cross product via
-- 'det' (measure leftness/rightness) is a much better choice to express what you
-- want.
--
-- For sorting a number of points by angle, use the fast 'pseudoAngle' function.
newtype Angle = Rad Double
    deriving (Angle -> Angle -> Bool
(Angle -> Angle -> Bool) -> (Angle -> Angle -> Bool) -> Eq Angle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Angle -> Angle -> Bool
== :: Angle -> Angle -> Bool
$c/= :: Angle -> Angle -> Bool
/= :: Angle -> Angle -> Bool
Eq)

instance MWC.Uniform Angle where
    uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m Angle
uniformM g
gen = (Double -> Angle) -> m Double -> m Angle
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Angle
deg ((Double, Double) -> g -> m Double
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(Double, Double) -> g -> m Double
MWC.uniformRM (Double
0, Double
360) g
gen)

instance NFData Angle where rnf :: Angle -> ()
rnf Angle
_ = ()

instance Show Angle where
    show :: Angle -> String
show (Rad Double
r) = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"deg %2.8f" (Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
180)

instance VectorSpace Angle where
    Rad Double
a +. :: Angle -> Angle -> Angle
+. Rad Double
b = Double -> Angle
Rad (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b)
    Rad Double
a -. :: Angle -> Angle -> Angle
-. Rad Double
b = Double -> Angle
Rad (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b)
    Double
a *. :: Double -> Angle -> Angle
*. Rad Double
b = Double -> Angle
Rad (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
b)
    negateV :: Angle -> Angle
negateV (Rad Double
a) = Double -> Angle
Rad (-Double
a)
    zero :: Angle
zero = Double -> Angle
Rad Double
0

-- | Degrees-based 'Angle' smart constructor.
deg :: Double -> Angle
deg :: Double -> Angle
deg Double
degrees = Double -> Angle
Rad (Double
degrees Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
180 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi)

-- | Radians-based 'Angle' smart constructor.
rad :: Double -> Angle
rad :: Double -> Angle
rad = Double -> Angle
Rad

-- | Get an angle’s value in degrees
getDeg :: Angle -> Double
getDeg :: Angle -> Double
getDeg (Rad Double
r) = Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
180

-- | Get an angle’s value in radians
getRad :: Angle -> Double
getRad :: Angle -> Double
getRad (Rad Double
r) = Double
r

-- | Get the angle’s value, normalized to one revolution. This makes e.g. 720° mean
-- the same as 360°, which is otherwise not true for 'Angle's – turning twice might
-- be something else than turning once, after all.
normalizeAngle
    :: Angle -- ^ Interval start
    -> Angle -- ^ Angle to normalize
    -> Angle -- ^ Angle normalized to the interval [start, start + deg 360)
normalizeAngle :: Angle -> Angle -> Angle
normalizeAngle Angle
start Angle
a = Double -> Angle
rad (Angle -> Double
getRad (Angle
a Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
-. Angle
start) Double -> Double -> Double
forall {a}. Real a => a -> a -> a
`rem'` (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi)) Angle -> Angle -> Angle
forall v. VectorSpace v => v -> v -> v
+. Angle
start
  where a
x rem' :: a -> a -> a
`rem'` a
m = (a
x a -> a -> a
forall {a}. Real a => a -> a -> a
`mod'` a
m a -> a -> a
forall a. Num a => a -> a -> a
+ a
m) a -> a -> a
forall {a}. Real a => a -> a -> a
`mod'` a
m

-- | Increases monotonically with angle. Useful pretty much only to sort points by
-- angle, but this it does particularly fast (in particular, it’s much faster than
-- 'atan2').
--
-- Here is a comparison between 'atan2'-based (blue) and
-- pseudoAtan2/'pseudoAngle'-based angle of \([0\ldots 360\deg)\). Both are
-- increasing monotonically over the entire interval, hence yield the same
-- properties when it comes to 'Ord' and sorting in particular.
--
-- <<docs/haddock/Geometry/Core/pseudo_angle.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/pseudo_angle.svg" 200 100 $ \_ -> do
--     let anglesDeg = takeWhile (< 180) [-180, -175 ..]
--         atan2Plot = Polyline $ do
--             angleDeg <- anglesDeg
--             let Vec2 x y = polar (deg angleDeg) 1
--             pure (Vec2 angleDeg (atan2 y x))
--         pseudoAtan2Plot = Polyline $ do
--             angleDeg <- anglesDeg
--             let vec = polar (deg angleDeg) 1
--             pure (Vec2 angleDeg (pseudoAngle vec))
--         trafo = transformBoundingBox
--             [atan2Plot, pseudoAtan2Plot]
--             (shrinkBoundingBox 10 [zero, Vec2 200 100])
--             def {_bbFitAspect = IgnoreAspect}
--     cairoScope $ do
--         sketch (transform trafo atan2Plot)
--         setColor (mma 0)
--         C.stroke
--     cairoScope $ do
--         sketch (transform trafo pseudoAtan2Plot)
--         setColor (mma 1)
--         C.stroke
-- :}
-- Generated file: size 5KB, crc32: 0xda270ddb
pseudoAngle :: Vec2 -> Double
pseudoAngle :: Vec2 -> Double
pseudoAngle (Vec2 Double
x Double
y) = Double -> Double -> Double
pseudoAtan2 Double
y Double
x

-- | Source of this nice alg:
-- https://vegard.wiki/w/Pseudoangles
pseudoAtan2 :: Double -> Double -> Double
pseudoAtan2 :: Double -> Double -> Double
pseudoAtan2 Double
y Double
x =  Double -> Double
forall a. Num a => a -> a
signum Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double -> Double
forall a. Num a => a -> a
abs Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Num a => a -> a
abs Double
y))

-- | Directional vector of a line, i.e. the vector pointing from start to end. The
-- norm of the vector is the length of the line. Use 'direction' if you need a
-- result of length 1.
vectorOf :: Line -> Vec2
vectorOf :: Line -> Vec2
vectorOf (Line Vec2
start Vec2
end) = Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start
{-# INLINE vectorOf #-}

-- | Where do you end up when walking 'Distance' on a 'Line'?
--
-- @
-- moveAlong (Line start end) 0 == start
-- moveAlong (Line start end) (lineLength …) == end
-- @
moveAlongLine
    :: Line
    -> Double -- ^ Distance
    -> Vec2
moveAlongLine :: Line -> Double -> Vec2
moveAlongLine line :: Line
line@(Line Vec2
start Vec2
_end) Double
d
  = let len :: Double
len = Line -> Double
lineLength Line
line
    in Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. (Double
dDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
len) Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. Line -> Vec2
vectorOf Line
line

-- | Angle of a single line, relative to the x axis.
--
-- For sorting by angle, use the faster 'pseudoAngle'!
angleOfLine :: Line -> Angle
angleOfLine :: Line -> Angle
angleOfLine (Line (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2)) = Double -> Angle
rad (Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 (Double
y2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y1) (Double
x2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x1))

-- | Angle between two lines.
--
-- The result depends on the direction of the lines; use 'lineReverse' if
-- necessary.
angleBetween :: Line -> Line -> Angle
angleBetween :: Line -> Line -> Angle
angleBetween Line
line1 Line
line2
  = let Rad Double
a1 = Line -> Angle
angleOfLine Line
line1
        Rad Double
a2 = Line -> Angle
angleOfLine Line
line2
    in Double -> Angle
rad (Double
a2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a1)

angledLine
    :: Vec2   -- ^ Start
    -> Angle
    -> Double -- ^ Length
    -> Line
angledLine :: Vec2 -> Angle -> Double -> Line
angledLine Vec2
start Angle
angle Double
len = Vec2 -> Vec2 -> Line
Line Vec2
start (Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Angle -> Double -> Vec2
polar Angle
angle Double
len)

lineLength :: Line -> Double
lineLength :: Line -> Double
lineLength = Vec2 -> Double
norm (Vec2 -> Double) -> (Line -> Vec2) -> Line -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Vec2
vectorOf

-- | Resize a line, keeping the starting point.
resizeLine :: (Double -> Double) -> Line -> Line
resizeLine :: (Double -> Double) -> Line -> Line
resizeLine Double -> Double
f line :: Line
line@(Line Vec2
start Vec2
_end)
  = let v :: Vec2
v = Line -> Vec2
vectorOf Line
line
        len :: Double
len = Vec2 -> Double
norm Vec2
v
        len' :: Double
len' = Double -> Double
f Double
len
        v' :: Vec2
v' = (Double
len'Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
len) Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. Vec2
v
        end' :: Vec2
end' = Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
v'
    in Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end'

-- | Resize a line, keeping the middle point.
resizeLineSymmetric :: (Double -> Double) -> Line -> Line
resizeLineSymmetric :: (Double -> Double) -> Line -> Line
resizeLineSymmetric Double -> Double
f line :: Line
line@(Line Vec2
start Vec2
end) = (Line -> Line
centerLine (Line -> Line) -> (Line -> Line) -> Line -> Line
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double) -> Line -> Line
resizeLine Double -> Double
f (Line -> Line) -> (Line -> Line) -> Line -> Line
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation -> Line -> Line
forall geo. Transform geo => Transformation -> geo -> geo
transform (Vec2 -> Transformation
translate Vec2
delta)) Line
line
  where
    middle :: Vec2
middle = Double
0.5 Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
end)
    delta :: Vec2
delta = Vec2
middle Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start

-- | Move the line so that its center is where the start used to be.
--
-- Useful for painting lines going through a point symmetrically.
centerLine :: Line -> Line
centerLine :: Line -> Line
centerLine (Line Vec2
start Vec2
end) =
    let middle :: Vec2
middle = Double
0.5 Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
end)
        end' :: Vec2
end' = Vec2
middle
        start' :: Vec2
start' = Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
middle
    in Vec2 -> Vec2 -> Line
Line Vec2
start' Vec2
end'

-- | Move the end point of the line so that it has length 1.
normalizeLine :: Line -> Line
normalizeLine :: Line -> Line
normalizeLine = (Double -> Double) -> Line -> Line
resizeLine (Double -> Double -> Double
forall a b. a -> b -> a
const Double
1)

-- | Distance of a point from a line.
distanceFromLine :: Vec2 -> Line -> Double
distanceFromLine :: Vec2 -> Line -> Double
distanceFromLine (Vec2 Double
ux Double
uy) (Line p1 :: Vec2
p1@(Vec2 Double
x1 Double
y1) p2 :: Vec2
p2@(Vec2 Double
x2 Double
y2))
  = let l :: Double
l = Vec2 -> Double
norm (Vec2
p2 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
p1)
    in Double -> Double
forall a. Num a => a -> a
abs ((Double
x2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x1)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
uy) Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
ux) Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
y2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y1)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
l

-- | Direction vector of a line.
direction :: Line -> Vec2
direction :: Line -> Vec2
direction = Line -> Vec2
vectorOf (Line -> Vec2) -> (Line -> Line) -> Line -> Vec2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Line
normalizeLine

-- | Switch defining points of a line.
--
-- <<docs/haddock/Geometry/Core/line_reverse.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/line_reverse.svg" 180 150 $ \_ -> do
--     let line = Line (Vec2 10 10) (Vec2 150 140)
--         line' = lineReverse line
--     C.setLineWidth 2
--     cairoScope $ do
--         sketch (Arrow line def)
--         C.stroke
--     cairoScope $ do
--         setColor (mma 1)
--         C.translate 20 0
--         sketch (Arrow line' def)
--         C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x2e031609
lineReverse :: Line -> Line
lineReverse :: Line -> Line
lineReverse (Line Vec2
start Vec2
end) = Vec2 -> Vec2 -> Line
Line Vec2
end Vec2
start

data LLIntersection
    = IntersectionReal Vec2
        -- ^ Two lines intersect fully.

    | IntersectionVirtualInsideL Vec2
        -- ^ The intersection is in the left argument (of 'intersectionLL')
        -- only, and only on the infinite continuation of the right argument.

    | IntersectionVirtualInsideR Vec2
        -- ^ dito, but the other way round.

    | IntersectionVirtual Vec2
        -- ^ The intersection lies in the infinite continuations of both lines.

    | Parallel
        -- ^ Lines are parallel.

    | Collinear (Maybe Line)
        -- ^ Lines are collinear, and maybe overlap along a 'Line' segment.

    deriving (LLIntersection -> LLIntersection -> Bool
(LLIntersection -> LLIntersection -> Bool)
-> (LLIntersection -> LLIntersection -> Bool) -> Eq LLIntersection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LLIntersection -> LLIntersection -> Bool
== :: LLIntersection -> LLIntersection -> Bool
$c/= :: LLIntersection -> LLIntersection -> Bool
/= :: LLIntersection -> LLIntersection -> Bool
Eq, Eq LLIntersection
Eq LLIntersection
-> (LLIntersection -> LLIntersection -> Ordering)
-> (LLIntersection -> LLIntersection -> Bool)
-> (LLIntersection -> LLIntersection -> Bool)
-> (LLIntersection -> LLIntersection -> Bool)
-> (LLIntersection -> LLIntersection -> Bool)
-> (LLIntersection -> LLIntersection -> LLIntersection)
-> (LLIntersection -> LLIntersection -> LLIntersection)
-> Ord LLIntersection
LLIntersection -> LLIntersection -> Bool
LLIntersection -> LLIntersection -> Ordering
LLIntersection -> LLIntersection -> LLIntersection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LLIntersection -> LLIntersection -> Ordering
compare :: LLIntersection -> LLIntersection -> Ordering
$c< :: LLIntersection -> LLIntersection -> Bool
< :: LLIntersection -> LLIntersection -> Bool
$c<= :: LLIntersection -> LLIntersection -> Bool
<= :: LLIntersection -> LLIntersection -> Bool
$c> :: LLIntersection -> LLIntersection -> Bool
> :: LLIntersection -> LLIntersection -> Bool
$c>= :: LLIntersection -> LLIntersection -> Bool
>= :: LLIntersection -> LLIntersection -> Bool
$cmax :: LLIntersection -> LLIntersection -> LLIntersection
max :: LLIntersection -> LLIntersection -> LLIntersection
$cmin :: LLIntersection -> LLIntersection -> LLIntersection
min :: LLIntersection -> LLIntersection -> LLIntersection
Ord, Int -> LLIntersection -> ShowS
[LLIntersection] -> ShowS
LLIntersection -> String
(Int -> LLIntersection -> ShowS)
-> (LLIntersection -> String)
-> ([LLIntersection] -> ShowS)
-> Show LLIntersection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LLIntersection -> ShowS
showsPrec :: Int -> LLIntersection -> ShowS
$cshow :: LLIntersection -> String
show :: LLIntersection -> String
$cshowList :: [LLIntersection] -> ShowS
showList :: [LLIntersection] -> ShowS
Show)

-- | Intersection of two infinite lines. Fast, but does not provide any error
-- handling (such as the parallel inputs case) and does not provide any detail
-- about the nature of the intersection point.
--
-- Use 'intersectionLL' for more detailed information, at the cost of computational
-- complexity.
intersectInfiniteLines :: Line -> Line -> Vec2
intersectInfiniteLines :: Line -> Line -> Vec2
intersectInfiniteLines (Line (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2)) (Line (Vec2 Double
x3 Double
y3) (Vec2 Double
x4 Double
y4)) = Double -> Double -> Vec2
Vec2 Double
x Double
y
  where
    x :: Double
x = ((Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x4)Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y4Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x4)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ ((Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y4)Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x4))
    y :: Double
y = ((Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y2Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y4)Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
y4Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
x4)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ ((Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y4)Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
y2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
x4))

-- | The single point of intersection of two lines, or 'Nothing' for none (collinear).
intersectionPoint :: LLIntersection -> Maybe Vec2
intersectionPoint :: LLIntersection -> Maybe Vec2
intersectionPoint (IntersectionReal Vec2
v)           = Vec2 -> Maybe Vec2
forall a. a -> Maybe a
Just Vec2
v
intersectionPoint (IntersectionVirtualInsideL Vec2
v) = Vec2 -> Maybe Vec2
forall a. a -> Maybe a
Just Vec2
v
intersectionPoint (IntersectionVirtualInsideR Vec2
v) = Vec2 -> Maybe Vec2
forall a. a -> Maybe a
Just Vec2
v
intersectionPoint (IntersectionVirtual Vec2
v)        = Vec2 -> Maybe Vec2
forall a. a -> Maybe a
Just Vec2
v
intersectionPoint LLIntersection
_                              = Maybe Vec2
forall a. Maybe a
Nothing

-- | Calculate the intersection of two lines.
--
-- Returns the point of the intersection, and whether it is inside both, one, or
-- none of the provided finite line segments.
--
-- See 'intersectInfiniteLines' for a more performant, but less nuanced result.
intersectionLL :: Line -> Line -> LLIntersection
intersectionLL :: Line -> Line -> LLIntersection
intersectionLL Line
lineL Line
lineR
    = LLIntersection
intersectionType
  where
    intersectionType :: LLIntersection
intersectionType
        | Double
discriminant Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
&& Vec2 -> Vec2 -> Double
cross (Vec2
v1 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
v2) (Vec2
v1 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
v3) Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0
          = LLIntersection
Parallel
        | Double
discriminant Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0
          = Maybe Line -> LLIntersection
Collinear (Maybe Line -> LLIntersection) -> Maybe Line -> LLIntersection
forall a b. (a -> b) -> a -> b
$ case (Vec2 -> Double) -> [Vec2] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vec2 -> Double
forwardness [Vec2
v2, Vec2
v3, Vec2
v4] of
            ~[Double
f2, Double
f3, Double
f4] | Double
f3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f2 Bool -> Bool -> Bool
&& Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f2 -> Maybe Line
forall a. Maybe a
Nothing
                          | Double
f3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0  Bool -> Bool -> Bool
&& Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0  -> Maybe Line
forall a. Maybe a
Nothing
                          | Double
f3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0  Bool -> Bool -> Bool
&& Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f2 -> Line -> Maybe Line
forall a. a -> Maybe a
Just Line
lineL
                          | Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0  Bool -> Bool -> Bool
&& Double
f3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f2 -> Line -> Maybe Line
forall a. a -> Maybe a
Just Line
lineL
                          | Double
f3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0              -> Line -> Maybe Line
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> Line
Line Vec2
v1 Vec2
v4)
                          | Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0              -> Line -> Maybe Line
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> Line
Line Vec2
v1 Vec2
v3)
                          | Double
f3 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f2             -> Line -> Maybe Line
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> Line
Line Vec2
v4 Vec2
v2)
                          | Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f2             -> Line -> Maybe Line
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> Line
Line Vec2
v3 Vec2
v2)
                          | Double
f4 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
f3             -> Line -> Maybe Line
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> Line
Line Vec2
v3 Vec2
v4)
                          | Bool
otherwise            -> Line -> Maybe Line
forall a. a -> Maybe a
Just (Vec2 -> Vec2 -> Line
Line Vec2
v4 Vec2
v3)
        | Bool
otherwise
          = case (Bool
intersectionInsideL, Bool
intersectionInsideR) of
            (Bool
True,  Bool
True)  -> Vec2 -> LLIntersection
IntersectionReal Vec2
iPoint
            (Bool
True,  Bool
False) -> Vec2 -> LLIntersection
IntersectionVirtualInsideL Vec2
iPoint
            (Bool
False, Bool
True)  -> Vec2 -> LLIntersection
IntersectionVirtualInsideR Vec2
iPoint
            (Bool
False, Bool
False) -> Vec2 -> LLIntersection
IntersectionVirtual Vec2
iPoint

    -- Calculation copied straight off of Wikipedia, then converted Latex to
    -- Haskell using bulk editing.
    --
    -- https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection

    Line Vec2
v1 Vec2
v2 = Line
lineL
    Line Vec2
v3 Vec2
v4 = Line
lineR

    discriminant :: Double
discriminant = Vec2 -> Vec2 -> Double
cross (Vec2
v1 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
v2) (Vec2
v3 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
v4)

    iPoint :: Vec2
iPoint = (Vec2 -> Vec2 -> Double
cross Vec2
v1 Vec2
v2 Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
v3 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
v4) Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2 -> Vec2 -> Double
cross Vec2
v3 Vec2
v4 Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
v1 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
v2)) Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/. Double
discriminant

    intersectionInsideL :: Bool
intersectionInsideL =
        let sol1 :: Ordering
sol1 = Line -> Vec2 -> Ordering
sideOfLine Line
lineR Vec2
v1
            sol2 :: Ordering
sol2 = Line -> Vec2 -> Ordering
sideOfLine Line
lineR Vec2
v2
        in Ordering
sol1 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
sol2 Bool -> Bool -> Bool
|| Ordering
sol1 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ Bool -> Bool -> Bool
|| Ordering
sol2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
    intersectionInsideR :: Bool
intersectionInsideR =
        let sol3 :: Ordering
sol3 = Line -> Vec2 -> Ordering
sideOfLine Line
lineL Vec2
v3
            sol4 :: Ordering
sol4 = Line -> Vec2 -> Ordering
sideOfLine Line
lineL Vec2
v4
        in Ordering
sol3 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
sol4 Bool -> Bool -> Bool
|| Ordering
sol3 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ Bool -> Bool -> Bool
|| Ordering
sol4 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

    sideOfLine :: Line -> Vec2 -> Ordering
    sideOfLine :: Line -> Vec2 -> Ordering
sideOfLine (Line Vec2
u Vec2
v) Vec2
p = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Vec2 -> Vec2 -> Double
cross (Vec2
v Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
u) (Vec2
p Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
u)) Double
0

    forwardness :: Vec2 -> Double
    forwardness :: Vec2 -> Double
forwardness Vec2
v = Vec2 -> Vec2 -> Double
dotProduct
        (Line -> Vec2
direction Line
lineL)
        (Line -> Vec2
direction (Vec2 -> Vec2 -> Line
Line Vec2
v1 Vec2
v))

-- | Subdivide a line into a number of equally long parts. Useful for
-- distorting straight lines. The first and last points are (exactly) equal to the
-- start and end of the input line.
--
-- See also 'subdivideLineByLength'.
--
-- <<docs/haddock/Geometry/Core/subdivide_line.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/subdivide_line.svg" 200 150 $ \_ -> do
--     let line = Line (Vec2 20 20) (Vec2 190 140)
--         subdivisions = subdivideLine 8 line
--     cairoScope $ do
--         C.setLineWidth 2
--         setColor (mma 0)
--         sketch line
--         C.stroke
--     cairoScope $ for_ subdivisions $ \point -> do
--         sketch (Circle point 4)
--         setColor (mma 1)
--         C.fill
-- :}
-- Generated file: size 4KB, crc32: 0x527103e6
subdivideLine
    :: Int -- ^ Number of segments
    -> Line
    -> [Vec2]
subdivideLine :: Int -> Line -> [Vec2]
subdivideLine Int
_ (Line Vec2
start Vec2
end) | Vec2
start Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
== Vec2
end = [Vec2
start, Vec2
end]
subdivideLine Int
numSegments line :: Line
line@(Line Vec2
start Vec2
end) = do
    let v :: Vec2
v = Line -> Vec2
vectorOf Line
line
    Int
segment <- [Int
0..Int
numSegments]
    Vec2 -> [Vec2]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Vec2 -> [Vec2]) -> Vec2 -> [Vec2]
forall a b. (a -> b) -> a -> b
$ if | Int
segment Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Vec2
start
              | Int
segment Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numSegments -> Vec2
end
              | Bool
otherwise -> let fraction :: Double
fraction = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segment Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numSegments
                             in Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double
fractionDouble -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*.Vec2
v

-- | Subdivide a line into evenly-sized intervals of a maximum length. Useful for
-- distorting straight lines. The first and last points are (exactly) equal to the
-- start and end of the input line.
--
-- See also 'subdivideLine.'.
--
-- <<docs/haddock/Geometry/Core/subdivide_line_by_length.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/subdivide_line_by_length.svg" 200 150 $ \_ -> do
--     let line = Line (Vec2 20 20) (Vec2 190 140)
--         subdivisions = subdivideLineByLength 30 line
--     cairoScope $ do
--         C.setLineWidth 2
--         setColor (mma 0)
--         sketch line
--         C.stroke
--     cairoScope $ for_ subdivisions $ \point -> do
--         sketch (Circle point 4)
--         setColor (mma 1)
--         C.fill
-- :}
-- Generated file: size 4KB, crc32: 0x6180122d
subdivideLineByLength
    :: Double
        -- ^ Maximum segment length. All segments will have the same length; to
        --   accomplish this, this value is an upper bound.
    -> Line
    -> [Vec2]
subdivideLineByLength :: Double -> Line -> [Vec2]
subdivideLineByLength Double
segmentLength Line
line =
    let numSegments :: Int
numSegments = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Line -> Double
lineLength Line
line Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
segmentLength)
    in Int -> Line -> [Vec2]
subdivideLine Int
numSegments Line
line

-- | All the polygon’s edges, in order, starting at an arbitrary corner.
--
-- <<docs/haddock/Geometry/Core/polygon_edges.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/polygon_edges.svg" 100 100 $ \_ -> do
--     let polygon = Polygon [ transform (rotateAround (Vec2 50 50) (deg d)) (Vec2 50 10) | d <- take 5 [0, 360/5 ..] ]
--     for_ (zip [0..] (polygonEdges polygon)) $ \(i, edge) -> do
--         C.setLineCap C.LineCapRound
--         setColor (mma i)
--         sketch edge
--         C.stroke
-- :}
-- Generated file: size 3KB, crc32: 0x9c27134b
polygonEdges :: Polygon -> [Line]
polygonEdges :: Polygon -> [Line]
polygonEdges (Polygon [Vec2]
ps) = (Vec2 -> Vec2 -> Line) -> [Vec2] -> [Vec2] -> [Line]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Vec2 -> Vec2 -> Line
Line [Vec2]
ps ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
ps))

-- | All interior angles, in order, starting at an arbitrary corner.
polygonAngles :: Polygon -> [Angle]
polygonAngles :: Polygon -> [Angle]
polygonAngles polygon :: Polygon
polygon@(Polygon [Vec2]
corners)
  = let orient :: (b -> b -> c) -> b -> b -> c
orient = case Polygon -> PolygonOrientation
polygonOrientation Polygon
polygon of
            PolygonOrientation
PolygonNegative -> (b -> b -> c) -> b -> b -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip
            PolygonOrientation
PolygonPositive -> (b -> b -> c) -> b -> b -> c
forall a. a -> a
id
        angle :: Vec2 -> Vec2 -> Vec2 -> Angle
angle Vec2
p Vec2
x Vec2
q = (Line -> Line -> Angle) -> Line -> Line -> Angle
forall {b} {c}. (b -> b -> c) -> b -> b -> c
orient Line -> Line -> Angle
angleBetween (Vec2 -> Vec2 -> Line
Line Vec2
x Vec2
q) (Vec2 -> Vec2 -> Line
Line Vec2
x Vec2
p)
        [Vec2]
_ : [Vec2]
corners1 : [Vec2]
corners2 : [[Vec2]]
_ = ([Vec2] -> [Vec2]) -> [Vec2] -> [[Vec2]]
forall a. (a -> a) -> a -> [a]
iterate [Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
corners)
    in (Vec2 -> Vec2 -> Vec2 -> Angle)
-> [Vec2] -> [Vec2] -> [Vec2] -> [Angle]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Vec2 -> Vec2 -> Vec2 -> Angle
angle [Vec2]
corners [Vec2]
corners1 [Vec2]
corners2

-- | The smallest convex polygon that contains all points.
--
-- <<docs/haddock/Geometry/Core/convex_hull.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/convex_hull.svg" 200 200 $ \(Vec2 w h) -> do
--     points <- C.liftIO $ MWC.withRng [] $ \gen ->
--         gaussianDistributedPoints
--             gen
--             (shrinkBoundingBox 10 [zero, Vec2 w h])
--             (30 *. mempty)
--             100
--     for_ points $ \point -> do
--         sketch (Circle point 3)
--         C.fill
--     setColor (mma 1)
--     for_ (polygonEdges (convexHull points)) $ \edge ->
--         sketch (Arrow edge def{_arrowheadRelPos=0.5, _arrowheadSize=5})
--     C.stroke
-- :}
-- Generated file: size 29KB, crc32: 0xe4bf922
convexHull :: Foldable list => list Vec2 -> Polygon
-- Andrew’s algorithm
convexHull :: forall (list :: * -> *). Foldable list => list Vec2 -> Polygon
convexHull list Vec2
points
  = let pointsSorted :: [Vec2]
pointsSorted = [Vec2] -> [Vec2]
forall a. Ord a => [a] -> [a]
sort (list Vec2 -> [Vec2]
forall a. list a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList list Vec2
points)
        angleSign :: Vec2 -> Vec2 -> Vec2 -> Double
angleSign Vec2
a Vec2
b Vec2
c = Double -> Double
forall a. Num a => a -> a
signum (Vec2 -> Vec2 -> Double
cross (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
a) (Vec2
c Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
b))
        go :: (Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
        go :: (Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
cmp [] (Vec2
p:[Vec2]
ps) = (Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
cmp [Vec2
p] [Vec2]
ps
        go Double -> Double -> Bool
cmp [Vec2
s] (Vec2
p:[Vec2]
ps) = (Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
cmp [Vec2
p,Vec2
s] [Vec2]
ps
        go Double -> Double -> Bool
cmp (Vec2
s:Vec2
t:[Vec2]
ack) (Vec2
p:[Vec2]
ps)
            | Vec2 -> Vec2 -> Vec2 -> Double
angleSign Vec2
t Vec2
s Vec2
p Double -> Double -> Bool
`cmp` Double
0 = (Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
cmp (Vec2
pVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:Vec2
sVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:Vec2
tVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:[Vec2]
ack) [Vec2]
ps
            | Bool
otherwise = (Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
cmp (Vec2
tVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:[Vec2]
ack) (Vec2
pVec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
:[Vec2]
ps)
        go Double -> Double -> Bool
_ [Vec2]
stack [] = [Vec2]
stack

    in [Vec2] -> Polygon
Polygon (Int -> [Vec2] -> [Vec2]
forall a. Int -> [a] -> [a]
drop Int
1 ((Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(<=) [] [Vec2]
pointsSorted) [Vec2] -> [Vec2] -> [Vec2]
forall a. [a] -> [a] -> [a]
++ Int -> [Vec2] -> [Vec2]
forall a. Int -> [a] -> [a]
drop Int
1 ([Vec2] -> [Vec2]
forall a. [a] -> [a]
reverse ((Double -> Double -> Bool) -> [Vec2] -> [Vec2] -> [Vec2]
go Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
(>=) [] [Vec2]
pointsSorted)))

-- | Orientation of a polygon
data PolygonOrientation
    = PolygonPositive -- ^ Counter-clockwise when plotted on a standard math coordinate system
    | PolygonNegative -- ^ Clockwise
    deriving (PolygonOrientation -> PolygonOrientation -> Bool
(PolygonOrientation -> PolygonOrientation -> Bool)
-> (PolygonOrientation -> PolygonOrientation -> Bool)
-> Eq PolygonOrientation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PolygonOrientation -> PolygonOrientation -> Bool
== :: PolygonOrientation -> PolygonOrientation -> Bool
$c/= :: PolygonOrientation -> PolygonOrientation -> Bool
/= :: PolygonOrientation -> PolygonOrientation -> Bool
Eq, Eq PolygonOrientation
Eq PolygonOrientation
-> (PolygonOrientation -> PolygonOrientation -> Ordering)
-> (PolygonOrientation -> PolygonOrientation -> Bool)
-> (PolygonOrientation -> PolygonOrientation -> Bool)
-> (PolygonOrientation -> PolygonOrientation -> Bool)
-> (PolygonOrientation -> PolygonOrientation -> Bool)
-> (PolygonOrientation -> PolygonOrientation -> PolygonOrientation)
-> (PolygonOrientation -> PolygonOrientation -> PolygonOrientation)
-> Ord PolygonOrientation
PolygonOrientation -> PolygonOrientation -> Bool
PolygonOrientation -> PolygonOrientation -> Ordering
PolygonOrientation -> PolygonOrientation -> PolygonOrientation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PolygonOrientation -> PolygonOrientation -> Ordering
compare :: PolygonOrientation -> PolygonOrientation -> Ordering
$c< :: PolygonOrientation -> PolygonOrientation -> Bool
< :: PolygonOrientation -> PolygonOrientation -> Bool
$c<= :: PolygonOrientation -> PolygonOrientation -> Bool
<= :: PolygonOrientation -> PolygonOrientation -> Bool
$c> :: PolygonOrientation -> PolygonOrientation -> Bool
> :: PolygonOrientation -> PolygonOrientation -> Bool
$c>= :: PolygonOrientation -> PolygonOrientation -> Bool
>= :: PolygonOrientation -> PolygonOrientation -> Bool
$cmax :: PolygonOrientation -> PolygonOrientation -> PolygonOrientation
max :: PolygonOrientation -> PolygonOrientation -> PolygonOrientation
$cmin :: PolygonOrientation -> PolygonOrientation -> PolygonOrientation
min :: PolygonOrientation -> PolygonOrientation -> PolygonOrientation
Ord, Int -> PolygonOrientation -> ShowS
[PolygonOrientation] -> ShowS
PolygonOrientation -> String
(Int -> PolygonOrientation -> ShowS)
-> (PolygonOrientation -> String)
-> ([PolygonOrientation] -> ShowS)
-> Show PolygonOrientation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PolygonOrientation -> ShowS
showsPrec :: Int -> PolygonOrientation -> ShowS
$cshow :: PolygonOrientation -> String
show :: PolygonOrientation -> String
$cshowList :: [PolygonOrientation] -> ShowS
showList :: [PolygonOrientation] -> ShowS
Show)

-- |
--
-- >>> polygonOrientation (Polygon [Vec2 0 0, Vec2 100 0, Vec2 100 100, Vec2 0 100])
-- PolygonPositive
--
-- >>> polygonOrientation (Polygon [Vec2 0 0, Vec2 0 100, Vec2 100 100, Vec2 100 0])
-- PolygonNegative
polygonOrientation :: Polygon -> PolygonOrientation
polygonOrientation :: Polygon -> PolygonOrientation
polygonOrientation Polygon
polygon
    | Polygon -> Double
signedPolygonArea Polygon
polygon Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = PolygonOrientation
PolygonPositive
    | Bool
otherwise                      = PolygonOrientation
PolygonNegative

-- | Circles are not an instance of 'Transform', because e.g. 'shear'ing a circle
-- yields an 'Ellipse'. To transform circles, convert them to an ellipse first with
-- 'toEllipse'.
data Circle = Circle
    { Circle -> Vec2
_circleCenter :: !Vec2
    , Circle -> Double
_circleRadius :: !Double
    } deriving (Circle -> Circle -> Bool
(Circle -> Circle -> Bool)
-> (Circle -> Circle -> Bool) -> Eq Circle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Circle -> Circle -> Bool
== :: Circle -> Circle -> Bool
$c/= :: Circle -> Circle -> Bool
/= :: Circle -> Circle -> Bool
Eq, Eq Circle
Eq Circle
-> (Circle -> Circle -> Ordering)
-> (Circle -> Circle -> Bool)
-> (Circle -> Circle -> Bool)
-> (Circle -> Circle -> Bool)
-> (Circle -> Circle -> Bool)
-> (Circle -> Circle -> Circle)
-> (Circle -> Circle -> Circle)
-> Ord Circle
Circle -> Circle -> Bool
Circle -> Circle -> Ordering
Circle -> Circle -> Circle
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Circle -> Circle -> Ordering
compare :: Circle -> Circle -> Ordering
$c< :: Circle -> Circle -> Bool
< :: Circle -> Circle -> Bool
$c<= :: Circle -> Circle -> Bool
<= :: Circle -> Circle -> Bool
$c> :: Circle -> Circle -> Bool
> :: Circle -> Circle -> Bool
$c>= :: Circle -> Circle -> Bool
>= :: Circle -> Circle -> Bool
$cmax :: Circle -> Circle -> Circle
max :: Circle -> Circle -> Circle
$cmin :: Circle -> Circle -> Circle
min :: Circle -> Circle -> Circle
Ord, Int -> Circle -> ShowS
[Circle] -> ShowS
Circle -> String
(Int -> Circle -> ShowS)
-> (Circle -> String) -> ([Circle] -> ShowS) -> Show Circle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Circle -> ShowS
showsPrec :: Int -> Circle -> ShowS
$cshow :: Circle -> String
show :: Circle -> String
$cshowList :: [Circle] -> ShowS
showList :: [Circle] -> ShowS
Show)

-- | Unit circle
instance Default Circle where
    def :: Circle
def = Vec2 -> Double -> Circle
Circle Vec2
forall v. VectorSpace v => v
zero Double
1

instance NFData Circle where rnf :: Circle -> ()
rnf Circle
_ = ()

-- | <<docs/haddock/Geometry/Core/bounding_box_circle.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/bounding_box_circle.svg" 150 150 $ \_ -> do
--     let circle = Circle (Vec2 75 75) 65
--     cairoScope $ do
--         setColor (mma 1)
--         C.setDash [1.5,3] 0
--         sketch (boundingBox circle)
--         C.stroke
--     cairoScope $ do
--         C.setLineWidth 2
--         sketch circle
--         C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x58f8a8af
instance HasBoundingBox Circle where
    boundingBox :: Circle -> BoundingBox
boundingBox (Circle Vec2
center Double
r) = (Vec2, Vec2) -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox (Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Double -> Double -> Vec2
Vec2 Double
r Double
r, Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
r Double
r)

-- | This allows applying a 'Transformation' to a 'Circle', which can e.g. be
-- useful to put circles in a 'transformBoundingBox' operation. See the 'Transform'
-- instance for details.
newtype UnsafeTransformCircle = UnsafeTransformCircle Circle

-- | Transform the circle as much as circles allow us. In order for the new circle
-- to have correct radius, the transformation must not contain:
--
--   * Shears (would yield an ellipse)
--   * Scaling by different amounts in x/y directions (dito) except mirroring
--
-- This instance is unsafe in the sense that it will yield a wrong result if these
-- requirements are not met, but it can be useful to do aspect ratio preserving
-- scales or translations of circles.
instance Transform UnsafeTransformCircle where
    transform :: Transformation -> UnsafeTransformCircle -> UnsafeTransformCircle
transform Transformation
t (UnsafeTransformCircle (Circle Vec2
center Double
radius)) =
        let center' :: Vec2
center' = Transformation -> Vec2 -> Vec2
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
t Vec2
center
            radius' :: Double
radius' = Double -> Double
forall a. Num a => a -> a
abs Double
scaleX Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
radius
            (Vec2
_, (Double
scaleX, Double
_), Double
_shear, Angle
_angle) = Transformation -> (Vec2, (Double, Double), Double, Angle)
decomposeTransformation Transformation
t
        in Circle -> UnsafeTransformCircle
UnsafeTransformCircle (Vec2 -> Double -> Circle
Circle Vec2
center' Double
radius')

-- | Embedding of 'Circle' as a special case of an 'Ellipse'.
toEllipse :: Circle -> Ellipse
toEllipse :: Circle -> Ellipse
toEllipse (Circle Vec2
center Double
radius) = Transformation -> Ellipse
Ellipse (Vec2 -> Transformation
translate Vec2
center Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Double -> Transformation
scale Double
radius)

-- | An 'Ellipse' is a 'Transformation' applied to the unit 'Circle'. Create them
-- using 'toEllipse' and by then applying 'Transformation's to it.
--
-- <<docs/haddock/Geometry/Core/ellipses.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/ellipses.svg" 300 300 $ \(Vec2 w h) -> do
--     let center = zero
--         radius = w/6*0.9
--         ellipse = toEllipse (Circle center radius)
--         grid i j = C.translate (fromIntegral i*w/3 + w/6) (fromIntegral j*h/3 + w/6)
--     let actions =
--             [ cairoScope $ do
--                 grid 0 0
--                 for_ (take 10 [0..]) $ \i -> do
--                     let scaleFactor = lerpID (0,9) (0.1, 1) i
--                     sketch (transform (scaleAround center scaleFactor) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 1 0
--                 for_ (take 10 [0..]) $ \i -> do
--                     let scaleFactor = lerpID (0,9) (0.1, 1) i
--                     sketch (transform (scaleAround' center scaleFactor 1) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 2 0
--                 for_ [0..9] $ \i -> do
--                     let scaleFactor1 = lerp (0, 9) (1, 0.1) (fromIntegral i)
--                         scaleFactor2 = lerp (0, 9) (0.1, 1) (fromIntegral i)
--                     sketch (transform (scaleAround' center scaleFactor1 scaleFactor2) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 0 1
--                 for_ (take 10 [0..]) $ \i -> do
--                     let scaleX = scaleAround' center (lerpID (0,9) (0.5,1) (fromIntegral i)) 1
--                         scaleY = scaleAround' center 1 (lerpID (0,9) (0.1,1) (fromIntegral i))
--                     sketch (transform (scaleX <> scaleY) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 1 1
--                 for_ (take 10 [0..]) $ \i -> do
--                     let angle = deg (lerpID (0,9) (0, 90) i)
--                     sketch (transform (rotateAround center angle <> scaleAround' center 1 0.5) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 2 1
--                 for_ (take 19 [0..]) $ \i -> do
--                     let angle = deg (lerpID (0,19) (0, 180) i)
--                     sketch (transform (rotateAround center angle <> scaleAround' center 1 0.5) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 0 2
--                 for_ (take 9 [0..]) $ \i -> do
--                     let scaleFactor = lerpID (0,9) (1,0.1) i
--                         angle = deg (lerpID (0,9) (90,0) i)
--                     sketch (transform (rotateAround center angle <> scaleAround' center 1 scaleFactor) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 1 2
--                 for_ (take 9 [0..]) $ \i -> do
--                     let scaleFactor = lerpID (0,9) (1,0.1) i
--                         angle = deg (lerpID (0,9) (0,90) i)
--                     sketch (transform (scaleAround center scaleFactor <> rotateAround center angle <> scaleAround' center 1 scaleFactor) ellipse)
--                     C.stroke
--             , cairoScope $ do
--                 grid 2 2
--                 for_ (take 9 [0..]) $ \i -> do
--                     let BoundingBox topLeft _ = boundingBox ellipse
--                         scaleFactor = lerpID (0,9) (1,0.1) i
--                         angle = deg (lerpID (0,9) (0,90) i)
--                     sketch (transform (rotateAround center angle <> scaleAround (0.5 *. (topLeft -. center)) scaleFactor) ellipse)
--                     C.stroke
--             ]
--     for_ (zip [0..] actions) $ \(i, action) -> do
--         setColor (mma i)
--         action
-- :}
-- Generated file: size 42KB, crc32: 0xb3cabf7b
newtype Ellipse = Ellipse Transformation
    deriving (Int -> Ellipse -> ShowS
[Ellipse] -> ShowS
Ellipse -> String
(Int -> Ellipse -> ShowS)
-> (Ellipse -> String) -> ([Ellipse] -> ShowS) -> Show Ellipse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ellipse -> ShowS
showsPrec :: Int -> Ellipse -> ShowS
$cshow :: Ellipse -> String
show :: Ellipse -> String
$cshowList :: [Ellipse] -> ShowS
showList :: [Ellipse] -> ShowS
Show)

instance NFData Ellipse where rnf :: Ellipse -> ()
rnf Ellipse
_ = ()

-- | Unit circle
instance Default Ellipse where def :: Ellipse
def = Transformation -> Ellipse
Ellipse Transformation
forall a. Monoid a => a
mempty



-- | <<docs/haddock/Geometry/Core/bounding_box_ellipse.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/bounding_box_ellipse.svg" 300 300 $ \(Vec2 w h) -> do
--     let radius = w/6*0.9
--         ellipse = toEllipse (Circle zero radius)
--         grid i j = C.translate (fromIntegral i*w/3 + w/6) (fromIntegral j*h/3 + w/6)
--         paintWithBB i j geo = cairoScope $ do
--             grid i j
--             setColor (mma (i*3+j))
--             cairoScope $ sketch geo >> C.stroke
--             cairoScope $ C.setDash [1.5,3] 0 >> sketch (boundingBox geo) >> C.stroke
--     paintWithBB 0 0 (transform (scale 0.9) ellipse)
--     paintWithBB 1 0 (transform (scale 0.75) ellipse)
--     paintWithBB 2 0 (transform (scale 0.5) ellipse)
--     paintWithBB 0 1 (transform (scale' 0.5 1) ellipse)
--     paintWithBB 1 1 (transform (scale' 1 0.5) ellipse)
--     paintWithBB 2 1 (transform (rotate (deg 30) <> scale' 0.5 1) ellipse)
--     paintWithBB 0 2 (transform (shear 0.3 0 <> scale' 0.5 1) ellipse)
--     paintWithBB 1 2 (transform (shear 0 0.3 <> scale' 1 0.5) ellipse)
--     paintWithBB 2 2 (transform (scale' 1 0.5 <> rotate (deg 45) <> shear 0 1 <> scale' 1 0.5) ellipse)
-- :}
-- Generated file: size 9KB, crc32: 0xcc4b0da9
instance HasBoundingBox Ellipse where
    boundingBox :: Ellipse -> BoundingBox
boundingBox (Ellipse (Transformation (Mat2 Double
a11 Double
a12 Double
a21 Double
a22) (Vec2 Double
b1 Double
b2))) =
        let -- https://tavianator.com/2014/ellipsoid_bounding_boxes.html
            x_plus :: Double
x_plus  = Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Floating a => a -> a
sqrt (Double
a11Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
a12Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
            x_minus :: Double
x_minus = Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
forall a. Floating a => a -> a
sqrt (Double
a11Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
a12Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
            y_plus :: Double
y_plus  = Double
b2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Floating a => a -> a
sqrt (Double
a21Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
a22Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
            y_minus :: Double
y_minus = Double
b2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
forall a. Floating a => a -> a
sqrt (Double
a21Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
a22Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)
        in (Vec2, Vec2) -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox (Double -> Double -> Vec2
Vec2 Double
x_plus Double
y_plus, Double -> Double -> Vec2
Vec2 Double
x_minus Double
y_minus)

instance Transform Ellipse where
    transform :: Transformation -> Ellipse -> Ellipse
transform Transformation
t (Ellipse Transformation
t') = Transformation -> Ellipse
Ellipse (Transformation
t Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
t')

-- | Total length of a 'Polyline'.
--
-- >>> polylineLength (Polyline [zero, Vec2 123.4 0])
-- 123.4
polylineLength :: Polyline -> Double
polylineLength :: Polyline -> Double
polylineLength = (Double -> Double -> Double) -> Double -> [Double] -> Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Double
0 ([Double] -> Double)
-> (Polyline -> [Double]) -> Polyline -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Line -> Double) -> [Line] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Double
lineLength ([Line] -> [Double])
-> (Polyline -> [Line]) -> Polyline -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polyline -> [Line]
polylineEdges

-- | All lines composing a 'Polyline' (in order).
--
-- >>> polylineEdges (Polyline [zero, Vec2 50 50, Vec2 100 0])
-- [Line (Vec2 0.0 0.0) (Vec2 50.0 50.0),Line (Vec2 50.0 50.0) (Vec2 100.0 0.0)]
polylineEdges :: Polyline -> [Line]
polylineEdges :: Polyline -> [Line]
polylineEdges (Polyline [Vec2]
points) = (Vec2 -> Vec2 -> Line) -> [Vec2] -> [Vec2] -> [Line]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Vec2 -> Vec2 -> Line
Line [Vec2]
points ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail [Vec2]
points)

-- | Ray-casting algorithm. Counts how many times a ray coming from infinity
-- intersects the edges of an object.
--
-- The most basic use case is 'pointInPolygon', but it can also be used to find
-- out whether something is inside more complicated objects, such as nested
-- polygons (polygons with holes).
countEdgeTraversals
    :: Foldable list
    => Vec2      -- ^ Point to check
    -> list Line -- ^ Geometry. Each segment must form a closed trajectory (or the ray may escape without registering).
    -> Int       -- ^ Number of edges crossed
countEdgeTraversals :: forall (list :: * -> *). Foldable list => Vec2 -> list Line -> Int
countEdgeTraversals Vec2
subjectPoint list Line
edges'
    | Vec2 -> BoundingBox -> Bool
forall thing bigObject.
(HasBoundingBox thing, HasBoundingBox bigObject) =>
thing -> bigObject -> Bool
overlappingBoundingBoxes Vec2
subjectPoint BoundingBox
edgesBB = [Line] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Line]
intersections
    | Bool
otherwise = Int
0

  where
    edges :: [Line]
edges = list Line -> [Line]
forall a. list a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList list Line
edges'
    edgesBB :: BoundingBox
edgesBB@(BoundingBox (Vec2 Double
leftmostX Double
_) Vec2
_) = [Line] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox [Line]
edges

    -- The test ray starts beyond the geometry, and ends at the point to be tested.
    --
    -- This ray is numerically sensitive, because exactly crossing a corner of the
    -- polygon might count as 0, 1 or 2 edges traversed. For this reason, we
    -- subtract 1 from the y coordinate as well to get a bit of an odd angle,
    -- greatly reducing the chance of exactly hitting a corner on the way.
    testRay :: Line
testRay = Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 (Double
leftmostX Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1) (Double
pointY Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1)) Vec2
subjectPoint
    Vec2 Double
_ Double
pointY = Vec2
subjectPoint

    intersections :: [Line]
intersections = (Line -> Bool) -> [Line] -> [Line]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Line
edge ->
        case Line -> Line -> LLIntersection
intersectionLL Line
testRay Line
edge of
            IntersectionReal Vec2
_ -> Bool
True
            LLIntersection
_other -> Bool
False)
        [Line]
edges

-- | Is the point inside the polygon?
--
-- <<docs/haddock/Geometry/Core/point_in_polygon.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/point_in_polygon.svg" 180 180 $ \_ -> do
--     let square = boundingBoxPolygon (shrinkBoundingBox 40 [zero, Vec2 180 180])
--         points = subdivideLine 11 (Line (Vec2 20 120) (Vec2 160 60))
--     C.setLineWidth 2
--     sketch square
--     C.stroke
--     setColor (mma 1)
--     for_ points $ \point -> do
--         sketch (Circle point 4)
--         if pointInPolygon point square then C.fill else C.stroke
-- :}
-- Generated file: size 5KB, crc32: 0xabb5dfc
pointInPolygon :: Vec2 -> Polygon -> Bool
pointInPolygon :: Vec2 -> Polygon -> Bool
pointInPolygon Vec2
p Polygon
poly = Int -> Bool
forall a. Integral a => a -> Bool
odd (Vec2 -> [Line] -> Int
forall (list :: * -> *). Foldable list => Vec2 -> list Line -> Int
countEdgeTraversals Vec2
p (Polygon -> [Line]
polygonEdges Polygon
poly))

data PolygonError
    = NotEnoughCorners Int
    | IdenticalPoints [Vec2]
    | SelfIntersections [(Line, Line)]
    deriving (PolygonError -> PolygonError -> Bool
(PolygonError -> PolygonError -> Bool)
-> (PolygonError -> PolygonError -> Bool) -> Eq PolygonError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PolygonError -> PolygonError -> Bool
== :: PolygonError -> PolygonError -> Bool
$c/= :: PolygonError -> PolygonError -> Bool
/= :: PolygonError -> PolygonError -> Bool
Eq, Eq PolygonError
Eq PolygonError
-> (PolygonError -> PolygonError -> Ordering)
-> (PolygonError -> PolygonError -> Bool)
-> (PolygonError -> PolygonError -> Bool)
-> (PolygonError -> PolygonError -> Bool)
-> (PolygonError -> PolygonError -> Bool)
-> (PolygonError -> PolygonError -> PolygonError)
-> (PolygonError -> PolygonError -> PolygonError)
-> Ord PolygonError
PolygonError -> PolygonError -> Bool
PolygonError -> PolygonError -> Ordering
PolygonError -> PolygonError -> PolygonError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PolygonError -> PolygonError -> Ordering
compare :: PolygonError -> PolygonError -> Ordering
$c< :: PolygonError -> PolygonError -> Bool
< :: PolygonError -> PolygonError -> Bool
$c<= :: PolygonError -> PolygonError -> Bool
<= :: PolygonError -> PolygonError -> Bool
$c> :: PolygonError -> PolygonError -> Bool
> :: PolygonError -> PolygonError -> Bool
$c>= :: PolygonError -> PolygonError -> Bool
>= :: PolygonError -> PolygonError -> Bool
$cmax :: PolygonError -> PolygonError -> PolygonError
max :: PolygonError -> PolygonError -> PolygonError
$cmin :: PolygonError -> PolygonError -> PolygonError
min :: PolygonError -> PolygonError -> PolygonError
Ord, Int -> PolygonError -> ShowS
[PolygonError] -> ShowS
PolygonError -> String
(Int -> PolygonError -> ShowS)
-> (PolygonError -> String)
-> ([PolygonError] -> ShowS)
-> Show PolygonError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PolygonError -> ShowS
showsPrec :: Int -> PolygonError -> ShowS
$cshow :: PolygonError -> String
show :: PolygonError -> String
$cshowList :: [PolygonError] -> ShowS
showList :: [PolygonError] -> ShowS
Show)

-- | Check whether the polygon satisfies the invariants assumed by many
-- algorithms,
--
--   * At least three corners
--   * No identical points
--   * No self-intersections
--
-- Returns the provided polygon on success.
validatePolygon :: Polygon -> Either PolygonError Polygon
validatePolygon :: Polygon -> Either PolygonError Polygon
validatePolygon = \Polygon
polygon -> do
    Polygon -> Either PolygonError ()
threeCorners Polygon
polygon
    Polygon -> Either PolygonError ()
noIdenticalPoints Polygon
polygon
    Polygon -> Either PolygonError ()
noSelfIntersections Polygon
polygon
    Polygon -> Either PolygonError Polygon
forall a. a -> Either PolygonError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Polygon
polygon
  where
    threeCorners :: Polygon -> Either PolygonError ()
threeCorners (Polygon [Vec2]
ps) = case [Vec2]
ps of
        (Vec2
_1:Vec2
_2:Vec2
_3:[Vec2]
_) -> () -> Either PolygonError ()
forall a. a -> Either PolygonError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Vec2]
_other       -> PolygonError -> Either PolygonError ()
forall a b. a -> Either a b
Left (Int -> PolygonError
NotEnoughCorners ([Vec2] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Vec2]
ps))

    noIdenticalPoints :: Polygon -> Either PolygonError ()
noIdenticalPoints (Polygon [Vec2]
corners) = case [Vec2] -> [Vec2]
forall a. Ord a => [a] -> [a]
nubOrd [Vec2]
corners of
        [Vec2]
uniques | [Vec2]
uniques [Vec2] -> [Vec2] -> Bool
forall a. Eq a => a -> a -> Bool
== [Vec2]
corners -> () -> Either PolygonError ()
forall a. a -> Either PolygonError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                | Bool
otherwise -> PolygonError -> Either PolygonError ()
forall a b. a -> Either a b
Left ([Vec2] -> PolygonError
IdenticalPoints ([Vec2]
corners [Vec2] -> [Vec2] -> [Vec2]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Vec2]
uniques))

    noSelfIntersections :: Polygon -> Either PolygonError ()
noSelfIntersections Polygon
polygon = case Polygon -> [(Line, Line)]
selfIntersectionPairs Polygon
polygon of
        [] -> () -> Either PolygonError ()
forall a. a -> Either PolygonError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [(Line, Line)]
intersections -> PolygonError -> Either PolygonError ()
forall a b. a -> Either a b
Left ([(Line, Line)] -> PolygonError
SelfIntersections [(Line, Line)]
intersections)

    selfIntersectionPairs :: Polygon -> [(Line, Line)]
    selfIntersectionPairs :: Polygon -> [(Line, Line)]
selfIntersectionPairs Polygon
poly
      = [ (Line
edge1, Line
edge2) | Line
_:Line
edge1:Line
_:[Line]
restEdges <- [Line] -> [[Line]]
forall a. [a] -> [[a]]
tails (Polygon -> [Line]
polygonEdges Polygon
poly)
                         , Line
edge2 <- [Line]
restEdges
                         -- Skip neighbouring edge because neighbours always intersect
                         -- , let Line e11 _e12 = edge1
                         -- , let Line _e21 e22 = edge2
                         -- -- , e12 /= e21
                         -- , e11 /= e22
                         , IntersectionReal Vec2
_ <- [Line -> Line -> LLIntersection
intersectionLL Line
edge1 Line
edge2]
                         ]

-- | Average of polygon vertices. Note that this is not the same as
-- 'polygonCentroid', which is much less influenced by clustered corners.
--
-- <<docs/haddock/Geometry/Core/polygon_average.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/polygon_average.svg" 100 100 $ \_ -> do
--     let polygon = Polygon [Vec2 10 10, Vec2 10 90, Vec2 20 70, Vec2 40 60, Vec2 30 40, Vec2 90 90, Vec2 80 20]
--         averate = polygonAverage polygon
--     sketch polygon
--     C.stroke
--     setColor (mma 1)
--     sketch (Circle averate 5)
--     sketch (Cross averate 5)
--     C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0xcf7a8233
polygonAverage :: Polygon -> Vec2
polygonAverage :: Polygon -> Vec2
polygonAverage (Polygon [Vec2]
corners)
  = let (Double
num, Vec2
total) = ((Double, Vec2) -> Vec2 -> (Double, Vec2))
-> (Double, Vec2) -> [Vec2] -> (Double, Vec2)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(!Double
n, !Vec2
vec) Vec2
corner -> (Double
nDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
1, Vec2
vec Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
corner)) (Double
0, Double -> Double -> Vec2
Vec2 Double
0 Double
0) [Vec2]
corners
    in (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
num) Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. Vec2
total

-- | The centroid or geometric center of mass of a polygon.
--
-- <<docs/haddock/Geometry/Core/polygon_centroid.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/polygon_centroid.svg" 100 100 $ \_ -> do
--     let polygon = Polygon [Vec2 10 10, Vec2 10 90, Vec2 20 70, Vec2 40 60, Vec2 30 40, Vec2 90 90, Vec2 80 20]
--         centroid = polygonCentroid polygon
--     sketch polygon
--     C.stroke
--     setColor (mma 1)
--     sketch (Circle centroid 5)
--     sketch (Cross centroid 5)
--     C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x4453ccc1
polygonCentroid :: Polygon -> Vec2
polygonCentroid :: Polygon -> Vec2
polygonCentroid poly :: Polygon
poly@(Polygon [Vec2]
ps) = Double
weight Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. [Vec2] -> Vec2
forall a. VectorSpace a => [a] -> a
vsum ((Vec2 -> Vec2 -> Vec2) -> [Vec2] -> [Vec2] -> [Vec2]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Vec2
p Vec2
q -> Vec2 -> Vec2 -> Double
cross Vec2
p Vec2
q Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
p Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
q)) [Vec2]
ps ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
ps)))
  where
    totalArea :: Double
totalArea = Polygon -> Double
signedPolygonArea Polygon
poly
    weight :: Double
weight = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
6 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
totalArea)

-- | Sum of all edge lengths.
polygonCircumference :: Polygon -> Double
polygonCircumference :: Polygon -> Double
polygonCircumference = (Double -> Line -> Double) -> Double -> [Line] -> Double
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Double
acc Line
edge -> Double
acc Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Line -> Double
lineLength Line
edge) Double
0 ([Line] -> Double) -> (Polygon -> [Line]) -> Polygon -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> [Line]
polygonEdges

-- | Move all edges of a polygon outwards by the specified amount. Negative values
-- shrink instead (or use 'shrinkPolygon').
--
-- <<docs/haddock/Geometry/Core/grow_polygon.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/grow_polygon.svg" 160 230 $ \_ -> do
--     let polygon = transform (scale 2) $ Polygon [Vec2 20 40, Vec2 20 80, Vec2 40 60, Vec2 60 80, Vec2 60 40, Vec2 40 20]
--     for_ [0,5..25] $ \offset -> cairoScope $ do
--         when (offset == 0) (C.setLineWidth 3)
--         setColor (icefire (Numerics.Interpolation.lerp (0,25) (0.5, 1) (fromIntegral offset)))
--         sketch (growPolygon (fromIntegral offset) polygon)
--         C.stroke
-- :}
-- Generated file: size 4KB, crc32: 0xd6cd58c1
growPolygon :: Double -> Polygon -> Polygon
growPolygon :: Double -> Polygon -> Polygon
growPolygon Double
offset Polygon
polygon =
    let oldEdges :: [Line]
oldEdges = Polygon -> [Line]
polygonEdges Polygon
polygon

        -- Alg idea:
        -- Compare edge with expanded/shrunken edge. Ears have reversed direction to before,
        -- so we drop all the ear edges, and recompute the intersections of the remaining edges.

        grownEdges :: [Line]
grownEdges =
            let offsetOriented :: Double
offsetOriented = case Polygon -> PolygonOrientation
polygonOrientation Polygon
polygon of
                    PolygonOrientation
PolygonNegative -> Double
offset
                    PolygonOrientation
PolygonPositive -> -Double
offset
            in (Line -> Line) -> [Line] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Line -> Line
moveLinePerpendicular Double
offsetOriented) [Line]
oldEdges

        newCorners :: [Vec2]
newCorners = [Vec2] -> [Vec2]
forall a. [a] -> [a]
rotateListRight1 ([Line] -> [Vec2]
adjacentIntersections [Line]
grownEdges)
                     -- We need to rotate the list by one, otherwise the edges
                     -- will be misaligned by one, and we’ll be comparing an
                     -- edge to a resized _other_ edge in the next step. Bit hacky,
                     -- refactorings welcome :-)

        oldAndNewEdges :: [(Line, Line)]
oldAndNewEdges = (Line -> Vec2 -> Vec2 -> (Line, Line))
-> [Line] -> [Vec2] -> [Vec2] -> [(Line, Line)]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
            (\Line
oldEdge Vec2
newCorner1 Vec2
newCorner2 -> (Line
oldEdge, Vec2 -> Vec2 -> Line
Line Vec2
newCorner1 Vec2
newCorner2))
            [Line]
oldEdges
            [Vec2]
newCorners
            ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
newCorners))

        sameDirection :: Line -> Line -> Bool
sameDirection Line
v Line
w = Vec2 -> Vec2 -> Double
dotProduct (Line -> Vec2
vectorOf Line
v) (Line -> Vec2
vectorOf Line
w) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0

        earsClipped :: [Line]
earsClipped = do
            (Line
oldEdge, Line
newEdge) <- [(Line, Line)]
oldAndNewEdges
            -- Ears have flipped directions so we can filter them out
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Line -> Line -> Bool
sameDirection Line
oldEdge Line
newEdge)
            Line -> [Line]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Line
newEdge

        earsClippedCorners :: [Vec2]
earsClippedCorners = [Line] -> [Vec2]
adjacentIntersections [Line]
earsClipped

    in [Vec2] -> Polygon
Polygon [Vec2]
earsClippedCorners

-- | Convenience version of 'growPolygon' for negative deltas.
--
-- <<docs/haddock/Geometry/Core/shrink_polygon.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/shrink_polygon.svg" 160 230 $ \_ -> do
--     let polygon = transform (scale 2) $ Polygon [Vec2 20 40, Vec2 20 80, Vec2 40 60, Vec2 60 80, Vec2 60 40, Vec2 40 20]
--     for_ [0,5..25] $ \offset -> cairoScope $ do
--         when (offset == 0) (C.setLineWidth 3)
--         setColor (icefire (Numerics.Interpolation.lerp (0,25) (0.5, 0) (fromIntegral offset)))
--         sketch (shrinkPolygon (fromIntegral offset) polygon)
--         C.stroke
-- :}
-- Generated file: size 4KB, crc32: 0x4a75ae5c
shrinkPolygon :: Double -> Polygon -> Polygon
shrinkPolygon :: Double -> Polygon -> Polygon
shrinkPolygon Double
delta = Double -> Polygon -> Polygon
growPolygon (-Double
delta)

rotateListRight1 :: [a] -> [a]
rotateListRight1 :: forall a. [a] -> [a]
rotateListRight1 [] = []
rotateListRight1 [a]
xs = [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
xs a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
xs

moveLinePerpendicular :: Double -> Line -> Line
moveLinePerpendicular :: Double -> Line -> Line
moveLinePerpendicular Double
offset Line
line =
    let -- | Rotate 90 degrees. Fast special case of 'transform (rotate ('deg' 90))'.
        rot90 :: Vec2 -> Vec2
        rot90 :: Vec2 -> Vec2
rot90 (Vec2 Double
x Double
y) = Double -> Double -> Vec2
Vec2 (-Double
y) Double
x
        dir :: Vec2
dir = Vec2 -> Vec2
rot90 (Line -> Vec2
direction Line
line)
    in Transformation -> Line -> Line
forall geo. Transform geo => Transformation -> geo -> geo
transform (Vec2 -> Transformation
translate (Double
offset Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. Vec2
dir)) Line
line

-- | Pairwise intersections of lines. Useful to reconstruct a polygon from a list of edges.
adjacentIntersections :: [Line] -> [Vec2]
adjacentIntersections :: [Line] -> [Vec2]
adjacentIntersections [Line]
edges = (Line -> Line -> Vec2) -> [Line] -> [Line] -> [Vec2]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
    (\edge1 :: Line
edge1@(Line Vec2
_ Vec2
fallback1) edge2 :: Line
edge2@(Line Vec2
fallback2 Vec2
_) -> case Line -> Line -> LLIntersection
intersectionLL Line
edge1 Line
edge2 of
        IntersectionVirtual Vec2
p        -> Vec2
p -- Most common case on growing
        IntersectionReal Vec2
p           -> Vec2
p -- Most common case on shrinking
        IntersectionVirtualInsideL Vec2
p -> Vec2
p -- Not sure when this might happen, but if it does that’s what it should do :-)
        IntersectionVirtualInsideR Vec2
p -> Vec2
p -- Dito
        LLIntersection
Parallel                     -> (Vec2
fallback1 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
fallback2) Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/. Double
2 -- Pathological polygon: edge goes back onto itself
        Collinear{}                  -> (Vec2
fallback1 Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
fallback2) Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/. Double
2 -- Collinear edges, drop the middle point
    )
    [Line]
edges
    ([Line] -> [Line]
forall a. HasCallStack => [a] -> [a]
tail ([Line] -> [Line]
forall a. HasCallStack => [a] -> [a]
cycle [Line]
edges))

-- | Two-dimensional cross product.
--
-- This is useful to calculate the (signed) area of the parallelogram spanned by
-- two vectors, or to check whether a vector is to the left or right of another
-- vector.
--
-- >>> cross (Vec2 1 0) (Vec2 1 0) -- Collinear
-- 0.0
--
-- >>> cross (Vec2 1 0) (Vec2 1 0.1) -- 2nd vec is in positive (counter-clockwise) direction
-- 0.1
--
-- >>> cross (Vec2 1 0) (Vec2 1 (-0.1)) -- 2nd vec is in negative (clockwise) direction
-- -0.1
--
-- <<docs/haddock/Geometry/Core/cross_product_leftness_rightness.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/cross_product_leftness_rightness.svg" 200 200 $ \_ -> do
--     let line = Line (Vec2 10 10) (Vec2 170 170)
--     points <- C.liftIO $ MWC.withRng [] $ \gen ->
--             poissonDisc gen (shrinkBoundingBox 10 [Vec2 50 50, Vec2 200 200]) 10 10
--     let MinMax lo hi = foldMap (\x -> MinMax x x) $ do
--             end <- points
--             let Line start _ = line
--             pure (cross (end -. start) (vectorOf line))
--     for_ points $ \end -> grouped (C.paintWithAlpha 0.7) $ do
--         let Line start _ = line
--         sketch (Line start end)
--         setColor (icefire (lerp (min lo (-hi),max (-lo) hi) (0,1) (cross (end -. start) (vectorOf line))))
--         C.stroke
--         sketch (Circle end 2)
--         C.fill
--     cairoScope $ do
--         C.setLineWidth 4
--         setColor black
--         sketch line
--         C.stroke
--         let Line start end = line
--         sketch (Circle start 4)
--         sketch (Circle end 4)
--         C.fill
-- :}
-- Generated file: size 118KB, crc32: 0x75a4133f
cross :: Vec2 -> Vec2 -> Double
cross :: Vec2 -> Vec2 -> Double
cross (Vec2 Double
x1 Double
y1) (Vec2 Double
x2 Double
y2) = Mat2 -> Double
det (Double -> Double -> Double -> Double -> Mat2
Mat2 Double
x1 Double
y1 Double
x2 Double
y2)

-- | Determinant a matrix.
det :: Mat2 -> Double
det :: Mat2 -> Double
det (Mat2 Double
a11 Double
a12 Double
a21 Double
a22) = Double
a11Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a22 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a12Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
a21

-- | Area of a polygon.
polygonArea :: Polygon -> Double
polygonArea :: Polygon -> Double
polygonArea = Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> (Polygon -> Double) -> Polygon -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Polygon -> Double
signedPolygonArea

-- | Area of a polygon. The result’s sign depends on orientation: 'PolygonPositive' 'Polygon's have positive area.
--
-- >>> signedPolygonArea (Polygon [Vec2 0 0, Vec2 10 0, Vec2 10 10, Vec2 0 10])
-- 100.0
--
-- >>> signedPolygonArea (Polygon [Vec2 0 0, Vec2 0 10, Vec2 10 10, Vec2 10 0])
-- -100.0
signedPolygonArea :: Polygon -> Double
signedPolygonArea :: Polygon -> Double
signedPolygonArea (Polygon [Vec2]
ps)
  = let determinants :: [Double]
determinants = (Vec2 -> Vec2 -> Double) -> [Vec2] -> [Vec2] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Vec2 -> Vec2 -> Double
cross [Vec2]
ps ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
ps))
    in [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
determinants Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2

-- | Check whether the polygon is convex.
--
-- <<docs/haddock/Geometry/Core/is_convex.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/is_convex.svg" 200 100 $ \_ -> do
--     let convex = Polygon [Vec2 10 10, Vec2 10 90, Vec2 90 90, Vec2 90 10]
--         concave = Polygon [Vec2 110 10, Vec2 110 90, Vec2 150 50, Vec2 190 90, Vec2 190 10]
--     for_ [convex, concave] $ \polygon -> do
--         if isConvex polygon
--             then setColor (mma 2)
--             else setColor (mma 3)
--         sketch polygon
--         C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x60a3e9a1
isConvex :: Polygon -> Bool
isConvex :: Polygon -> Bool
isConvex (Polygon [Vec2]
ps) = [Double] -> Bool
forall {a}. (Eq a, Num a) => [a] -> Bool
allSameSign [Double]
angleDotProducts
    -- The idea is that a polygon is convex iff all internal angles are in the
    -- same direction. The direction of an angle defined by two vectors shares
    -- its sign with the signed area spanned by those vectors, and the latter is
    -- easy to calculate via a determinant.
  where
    angleDotProducts :: [Double]
angleDotProducts = (Vec2 -> Vec2 -> Vec2 -> Double)
-> [Vec2] -> [Vec2] -> [Vec2] -> [Double]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3
        (\Vec2
p Vec2
q Vec2
r -> Vec2 -> Vec2 -> Double
cross (Vec2
q Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
p) (Vec2
r Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
q) )
        [Vec2]
ps
        ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
ps))
        ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
tail ([Vec2] -> [Vec2]
forall a. HasCallStack => [a] -> [a]
cycle [Vec2]
ps)))

    allSameSign :: [a] -> Bool
allSameSign [] = Bool
True
    allSameSign (a
x:[a]
xs) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\a
p -> a -> a
forall a. Num a => a -> a
signum a
p a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a
forall a. Num a => a -> a
signum a
x) [a]
xs

-- | The result has the same length as the input, point in its center, and
-- points to the left (90° turned CCW) relative to the input.
--
-- <<docs/haddock/Geometry/Core/perpendicular_bisector.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/perpendicular_bisector.svg" 200 160 $ \_ -> do
--     let line = Line (Vec2 20 20) (Vec2 190 90)
--         bisector = perpendicularBisector line
--     C.setLineWidth 2
--     sketch line >> C.stroke
--     sketch bisector >> setColor (mma 1) >> C.stroke
-- :}
-- Generated file: size 2KB, crc32: 0x9940c32d
perpendicularBisector :: Line -> Line
perpendicularBisector :: Line -> Line
perpendicularBisector (Line Vec2
start Vec2
end) =
    let middle :: Vec2
middle = Double
0.5 Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. (Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
start)
    in Line -> Line
rotateLine90 (Vec2 -> Vec2 -> Line
Line Vec2
middle Vec2
end)

rotateLine90 :: Line -> Line
rotateLine90 :: Line -> Line
rotateLine90 (Line Vec2
start Vec2
end) = Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end'
  where
    end' :: Vec2
end' = Vec2 -> Vec2
rotate90 (Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start) Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
start

rotate90 :: Vec2 -> Vec2
rotate90 :: Vec2 -> Vec2
rotate90 (Vec2 Double
x Double
y) = Double -> Double -> Vec2
Vec2 (-Double
y) Double
x

-- | Line perpendicular to a given line through a point, starting at the
-- intersection point and pointing away from the line.
--
-- If the point is on the line directly, fall back to a perpendicular line through
-- the point of half the length of the input.
--
-- This is also known as the vector projection. For vectors \(\mathbf a\) (pointing
-- from the start of the line to \(\mathbf p\)) and \(\mathbf b\) (pointing from
-- the start of the line to its end),
--
-- \[
-- \mathrm{proj}_{\mathbf b}(\mathbf a)
-- = \frac{\mathbf a\cdot\mathbf b}{\mathbf b\cdot\mathbf b}\mathbf b
-- \]
--
-- <<docs/haddock/Geometry/Core/perpendicular_line_through.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/perpendicular_line_through.svg" 170 170 $ \_ -> do
--     let line = transform (translate (Vec2 20 20))
--                          (Line zero (Vec2 (3*40) (4*20)))
--         points =
--             [ Vec2 20 110  -- above
--             , Vec2 70 90   -- above
--             , Vec2 130 20  -- below
--             , Vec2 110 80  -- directly on
--             , Vec2 130 150 -- beyond
--             ]
--     C.setLineWidth 2
--     sketch line >> C.stroke
--     for_ (zip [1..] points) $ \(i, p) -> cairoScope $ do
--         setColor (mma i)
--         sketch (Arrow (perpendicularLineThrough p line) def)
--         C.stroke
--         sketch (Circle p 5)
--         C.strokePreserve
--         setColor (mma i `withOpacity` 0.7)
--         C.fill
-- :}
-- Generated file: size 6KB, crc32: 0xf5ff8529
perpendicularLineThrough :: Vec2 -> Line -> Line
perpendicularLineThrough :: Vec2 -> Line -> Line
perpendicularLineThrough Vec2
p (Line Vec2
start Vec2
end) =
    let a :: Vec2
a = Vec2
p Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start
        b :: Vec2
b = Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start
        proj :: Vec2
proj = (Vec2 -> Vec2 -> Double
dotProduct Vec2
a Vec2
bDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Vec2 -> Vec2 -> Double
dotProduct Vec2
b Vec2
b) Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
start
    in if Vec2 -> Double
normSquare (Vec2
p Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
proj) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0.01Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2
        then -- p is too close to proj, so a 'Line' does not make
             -- any sense. Fall back to a line of half the input
             -- length perpendicular to the original one.
            let p' :: Vec2
p' = Vec2
proj Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2 -> Vec2
rotate90 ((Vec2
end Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
start) Vec2 -> Double -> Vec2
forall v. VectorSpace v => v -> Double -> v
/. Double
2)
            in Vec2 -> Vec2 -> Line
Line Vec2
proj Vec2
p'
        else Vec2 -> Vec2 -> Line
Line Vec2
proj Vec2
p

-- | Optical reflection of a ray on a mirror. Note that the outgoing line has
-- reversed direction like light rays would. The second result element is the
-- point of intersection with the mirror, which is not necessarily on the line,
-- and thus returned separately.
--
-- <<docs/haddock/Geometry/Core/reflection.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Core/reflection.svg" 520 300 $ \_ -> do
--    let mirrorSurface = angledLine (Vec2 10 100) (deg 10) 510
--    cairoScope $ do
--        C.setLineWidth 2
--        setColor (black `withOpacity` 0.5)
--        sketch mirrorSurface
--        C.stroke
--    let angles = [-135,-120.. -10]
--    cairoScope $ do
--        let rayOrigin = Vec2 180 250
--        setColor (hsv 0 1 0.7)
--        sketch (Circle rayOrigin 5)
--        C.stroke
--        for_ angles $ \angleDeg -> do
--            let rayRaw = angledLine rayOrigin (deg angleDeg) 100
--                Just (Line _ reflectedRayEnd, iPoint, _) = reflection rayRaw mirrorSurface
--                ray = Line rayOrigin iPoint
--                ray' = Line iPoint reflectedRayEnd
--            setColor (flare (lerp (minimum angles, maximum angles) (0.2,0.8) angleDeg))
--            sketch ray
--            sketch ray'
--            C.stroke
--    cairoScope $ do
--        let rayOrigin = Vec2 350 30
--        setColor (hsva 180 1 0.7 1)
--        sketch (Circle rayOrigin 5)
--        C.stroke
--        for_ angles $ \angleDeg -> do
--            let rayRaw = angledLine rayOrigin (deg angleDeg) 100
--                Just (Line _ reflectedRayEnd, iPoint, _) = reflection rayRaw mirrorSurface
--                ray = Line rayOrigin iPoint
--                ray' = Line iPoint reflectedRayEnd
--            setColor (crest (lerp (minimum angles, maximum angles) (0,1) angleDeg))
--            sketch ray
--            sketch ray'
--            C.stroke
-- :}
-- Generated file: size 9KB, crc32: 0x76885f25
reflection
    :: Line -- ^ Light ray
    -> Line -- ^ Mirror
    -> Maybe (Line, Vec2, LLIntersection)
            -- ^ Reflected ray; point of incidence; type of intersection of the
            -- ray with the mirror. The reflected ray is symmetric with respect
            -- to the incoming ray (in terms of length, distance from mirror,
            -- etc.), but has reversed direction (like real light).
reflection :: Line -> Line -> Maybe (Line, Vec2, LLIntersection)
reflection Line
ray Line
mirror
  = let iType :: LLIntersection
iType = Line -> Line -> LLIntersection
intersectionLL Line
ray Line
mirror
    in  case LLIntersection -> Maybe Vec2
intersectionPoint LLIntersection
iType of
        Maybe Vec2
Nothing     -> Maybe (Line, Vec2, LLIntersection)
forall a. Maybe a
Nothing
        Just Vec2
iPoint -> (Line, Vec2, LLIntersection) -> Maybe (Line, Vec2, LLIntersection)
forall a. a -> Maybe a
Just (Line -> Line
lineReverse Line
ray', Vec2
iPoint, LLIntersection
iType)
          where
            mirrorAxis :: Line
mirrorAxis = Vec2 -> Line -> Line
perpendicularLineThrough Vec2
iPoint Line
mirror
            ray' :: Line
ray' = Transformation -> Line -> Line
forall geo. Transform geo => Transformation -> geo -> geo
transform (Line -> Transformation
mirrorAlong Line
mirrorAxis) Line
ray