{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeFamilies     #-}

{-# OPTIONS_GHC -fno-warn-unused-imports #-}
  -- for Data.Semigroup

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Shapes
-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Various two-dimensional shapes.
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Shapes
       (
         -- * Miscellaneous
         hrule, vrule

         -- * Regular polygons

       , regPoly
       , triangle
       , eqTriangle
       , square
       , pentagon
       , hexagon
       , heptagon
       , septagon
       , octagon
       , nonagon
       , decagon
       , hendecagon
       , dodecagon

         -- * Other special polygons
       , unitSquare
       , rect

         -- * Other shapes

       , roundedRect
       , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR
       , roundedRect'
       ) where

import           Control.Lens            (makeLenses, op, (&), (.~), (<>~), (^.))
import           Data.Default.Class
import           Data.Semigroup

import           Diagrams.Core

import           Diagrams.Angle
import           Diagrams.Located        (at)
import           Diagrams.Path
import           Diagrams.Segment
import           Diagrams.Trail
import           Diagrams.TrailLike
import           Diagrams.TwoD.Arc
import           Diagrams.TwoD.Polygons
import           Diagrams.TwoD.Transform
import           Diagrams.TwoD.Types
import           Diagrams.TwoD.Vector
import           Diagrams.Util


-- | Create a centered horizontal (L-R) line of the given length.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg#diagram=hruleEx&width=300>>
--
--   > hruleEx = vcat' (with & sep .~ 0.2) (map hrule [1..5])
--   >         # centerXY # pad 1.1
hrule :: (InSpace V2 n t, TrailLike t) => n -> t
hrule :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
hrule n
d = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail (V t) (N t)) -> t)
-> Located (Trail (V t) (N t)) -> t
forall a b. (a -> b) -> a -> b
$ [Segment Closed V2 n] -> Trail V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments [V2 n -> Segment Closed V2 n
forall (v :: * -> *) n. v n -> Segment Closed v n
straight (V2 n -> Segment Closed V2 n) -> V2 n -> Segment Closed V2 n
forall a b. (a -> b) -> a -> b
$ (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
d, n
0)] Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (-n
dn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2,n
0)

-- | Create a centered vertical (T-B) line of the given length.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg#diagram=vruleEx&height=100>>
--
--   > vruleEx = hcat' (with & sep .~ 0.2) (map vrule [1, 1.2 .. 2])
--   >         # centerXY # pad 1.1
vrule :: (InSpace V2 n t, TrailLike t) => n -> t
vrule :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
vrule n
d = Located (Trail (V t) (N t)) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail (V t) (N t)) -> t)
-> Located (Trail (V t) (N t)) -> t
forall a b. (a -> b) -> a -> b
$ [Segment Closed V2 n] -> Trail V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments [V2 n -> Segment Closed V2 n
forall (v :: * -> *) n. v n -> Segment Closed v n
straight (V2 n -> Segment Closed V2 n) -> V2 n -> Segment Closed V2 n
forall a b. (a -> b) -> a -> b
$ (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2 (n
0, -n
d)] Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (n
0,n
dn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2)

-- | A square with its center at the origin and sides of length 1,
--   oriented parallel to the axes.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg#diagram=unitSquareEx&width=100>>
unitSquare :: (InSpace V2 n t, TrailLike t) => t
unitSquare :: forall n t. (InSpace V2 n t, TrailLike t) => t
unitSquare = PolygonOpts n -> t
forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (PolygonOpts n
forall a. Default a => a
def PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyType n -> Identity (PolyType n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyType n -> f (PolyType n))
-> PolygonOpts n -> f (PolygonOpts n)
polyType   ((PolyType n -> Identity (PolyType n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyType n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> n -> PolyType n
forall n. Int -> n -> PolyType n
PolyRegular Int
4 (n -> n
forall a. Floating a => a -> a
sqrt n
2 n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2)
                          PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyOrientation n -> Identity (PolyOrientation n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyOrientation n -> f (PolyOrientation n))
-> PolygonOpts n -> f (PolygonOpts n)
polyOrient ((PolyOrientation n -> Identity (PolyOrientation n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyOrientation n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyOrientation n
forall n. PolyOrientation n
OrientH)

-- > unitSquareEx = unitSquare # pad 1.1 # showOrigin

-- | A square with its center at the origin and sides of the given
--   length, oriented parallel to the axes.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg#diagram=squareEx&width=200>>
square :: (InSpace V2 n t, TrailLike t) => n -> t
square :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
square n
d = n -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect n
d n
d

-- > squareEx = hcat' (with & sep .~ 0.5) [square 1, square 2, square 3]
-- >          # centerXY # pad 1.1

-- | @rect w h@ is an axis-aligned rectangle of width @w@ and height
--   @h@, centered at the origin.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg#diagram=rectEx&width=150>>
rect :: (InSpace V2 n t, TrailLike t) => n -> n -> t
rect :: forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect n
w n
h = Located (Trail (V t) (N t)) -> t
Located (Trail V2 n) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail V2 n) -> t)
-> (Path V2 n -> Located (Trail V2 n)) -> Path V2 n -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Located (Trail V2 n)] -> Located (Trail V2 n)
forall a. HasCallStack => [a] -> a
head ([Located (Trail V2 n)] -> Located (Trail V2 n))
-> (Path V2 n -> [Located (Trail V2 n)])
-> Path V2 n
-> Located (Trail V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwrapped (Path V2 n) -> Path V2 n)
-> Path V2 n -> Unwrapped (Path V2 n)
forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op [Located (Trail V2 n)] -> Path V2 n
Unwrapped (Path V2 n) -> Path V2 n
forall (v :: * -> *) n. [Located (Trail v n)] -> Path v n
Path (Path V2 n -> t) -> Path V2 n -> t
forall a b. (a -> b) -> a -> b
$ Path V2 n
forall n t. (InSpace V2 n t, TrailLike t) => t
unitSquare Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# n -> Path V2 n -> Path V2 n
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX n
w Path V2 n -> (Path V2 n -> Path V2 n) -> Path V2 n
forall a b. a -> (a -> b) -> b
# n -> Path V2 n -> Path V2 n
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY n
h

-- > rectEx = rect 1 0.7 # pad 1.1

    -- The above may seem a bit roundabout.  In fact, we used to have
    --
    --   rect w h = unitSquare # scaleX w # scaleY h
    --
    -- since unitSquare can produce any TrailLike.  The current code
    -- instead uses (unitSquare # scaleX w # scaleY h) to specifically
    -- produce a Path, which is then deconstructed and passed back into
    -- 'trailLike' to create any TrailLike.
    --
    -- The difference is that while scaling by zero works fine for
    -- Path it does not work very well for, say, Diagrams (leading to
    -- NaNs or worse).  This way, we force the scaling to happen on a
    -- Path, where we know it will behave properly, and then use the
    -- resulting geometry to construct an arbitrary TrailLike.
    --
    -- See https://github.com/diagrams/diagrams-lib/issues/43 .

------------------------------------------------------------
--  Regular polygons
------------------------------------------------------------

-- | Create a regular polygon. The first argument is the number of
--   sides, and the second is the /length/ of the sides. (Compare to the
--   'polygon' function with a 'PolyRegular' option, which produces
--   polygons of a given /radius/).
--
--   The polygon will be oriented with one edge parallel to the x-axis.
regPoly :: (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly :: forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
n n
l = PolygonOpts n -> t
forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (PolygonOpts n
forall a. Default a => a
def PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyType n -> Identity (PolyType n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyType n -> f (PolyType n))
-> PolygonOpts n -> f (PolygonOpts n)
polyType ((PolyType n -> Identity (PolyType n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyType n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~
                               [Angle n] -> [n] -> PolyType n
forall n. [Angle n] -> [n] -> PolyType n
PolySides
                                 (Angle n -> [Angle n]
forall a. a -> [a]
repeat (n
1n -> n -> n
forall a. Fractional a => a -> a -> a
/Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n n -> AReview (Angle n) n -> Angle n
forall b a. b -> AReview a b -> a
@@ AReview (Angle n) n
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle n) n
turn))
                                 (Int -> n -> [n]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) n
l)
                           PolygonOpts n -> (PolygonOpts n -> PolygonOpts n) -> PolygonOpts n
forall a b. a -> (a -> b) -> b
& (PolyOrientation n -> Identity (PolyOrientation n))
-> PolygonOpts n -> Identity (PolygonOpts n)
forall n (f :: * -> *).
Functor f =>
(PolyOrientation n -> f (PolyOrientation n))
-> PolygonOpts n -> f (PolygonOpts n)
polyOrient ((PolyOrientation n -> Identity (PolyOrientation n))
 -> PolygonOpts n -> Identity (PolygonOpts n))
-> PolyOrientation n -> PolygonOpts n -> PolygonOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PolyOrientation n
forall n. PolyOrientation n
OrientH
                           )

-- > shapeEx sh   = sh 1 # pad 1.1
-- > triangleEx   = shapeEx triangle
-- > pentagonEx   = shapeEx pentagon
-- > hexagonEx    = shapeEx hexagon
-- > heptagonEx   = shapeEx heptagon
-- > octagonEx    = shapeEx octagon
-- > nonagonEx    = shapeEx nonagon
-- > decagonEx    = shapeEx decagon
-- > hendecagonEx = shapeEx hendecagon
-- > dodecagonEx  = shapeEx dodecagon

-- | A synonym for 'triangle', provided for backwards compatibility.
eqTriangle :: (InSpace V2 n t, TrailLike t) => n -> t
eqTriangle :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
eqTriangle = n -> t
forall n t. (InSpace V2 n t, TrailLike t) => n -> t
triangle

-- | An equilateral triangle, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg#diagram=triangleEx&width=100>>
triangle :: (InSpace V2 n t, TrailLike t) => n -> t
triangle :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
triangle = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
3

-- | A regular pentagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg#diagram=pentagonEx&width=100>>
pentagon :: (InSpace V2 n t, TrailLike t) => n -> t
pentagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
pentagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
5

-- | A regular hexagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg#diagram=hexagonEx&width=100>>
hexagon :: (InSpace V2 n t, TrailLike t) => n -> t
hexagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
hexagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
6

-- | A regular heptagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg#diagram=heptagonEx&width=100>>
heptagon :: (InSpace V2 n t, TrailLike t) => n -> t
heptagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
heptagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
7

-- | A synonym for 'heptagon'.  It is, however, completely inferior,
--   being a base admixture of the Latin /septum/ (seven) and the
--   Greek γωνία (angle).
septagon :: (InSpace V2 n t, TrailLike t) => n -> t
septagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
septagon = n -> t
forall n t. (InSpace V2 n t, TrailLike t) => n -> t
heptagon

-- | A regular octagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg#diagram=octagonEx&width=100>>
octagon :: (InSpace V2 n t, TrailLike t) => n -> t
octagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
octagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
8

-- | A regular nonagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg#diagram=nonagonEx&width=100>>
nonagon :: (InSpace V2 n t, TrailLike t) => n -> t
nonagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
nonagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
9

-- | A regular decagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg#diagram=decagonEx&width=100>>
decagon :: (InSpace V2 n t, TrailLike t) => n -> t
decagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
decagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
10

-- | A regular hendecagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg#diagram=hendecagonEx&width=100>>
hendecagon :: (InSpace V2 n t, TrailLike t) => n -> t
hendecagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
hendecagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
11

-- | A regular dodecagon, with sides of the given length and base
--   parallel to the x-axis.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg#diagram=dodecagonEx&width=100>>
dodecagon :: (InSpace V2 n t, TrailLike t) => n -> t
dodecagon :: forall n t. (InSpace V2 n t, TrailLike t) => n -> t
dodecagon = Int -> n -> t
forall n t. (InSpace V2 n t, TrailLike t) => Int -> n -> t
regPoly Int
12

------------------------------------------------------------
--  Other shapes  ------------------------------------------
------------------------------------------------------------
data RoundedRectOpts d = RoundedRectOpts { forall d. RoundedRectOpts d -> d
_radiusTL :: d
                                         , forall d. RoundedRectOpts d -> d
_radiusTR :: d
                                         , forall d. RoundedRectOpts d -> d
_radiusBL :: d
                                         , forall d. RoundedRectOpts d -> d
_radiusBR :: d
                                         }

makeLenses ''RoundedRectOpts

instance (Num d) => Default (RoundedRectOpts d) where
  def :: RoundedRectOpts d
def = d -> d -> d -> d -> RoundedRectOpts d
forall d. d -> d -> d -> d -> RoundedRectOpts d
RoundedRectOpts d
0 d
0 d
0 d
0

-- | @roundedRect w h r@ generates a closed trail, or closed path
--   centered at the origin, of an axis-aligned rectangle with width
--   @w@, height @h@, and circular rounded corners of radius @r@.  If
--   @r@ is negative the corner will be cut out in a reverse arc. If
--   the size of @r@ is larger than half the smaller dimension of @w@
--   and @h@, then it will be reduced to fit in that range, to prevent
--   the corners from overlapping.  The trail or path begins with the
--   right edge and proceeds counterclockwise.  If you need to specify
--   a different radius for each corner individually, use
--   'roundedRect'' instead.
--
--   <<diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg#diagram=roundedRectEx&width=400>>
--
--   > roundedRectEx = pad 1.1 . centerXY $ hcat' (with & sep .~ 0.2)
--   >   [ roundedRect  0.5 0.4 0.1
--   >   , roundedRect  0.5 0.4 (-0.1)
--   >   , roundedRect' 0.7 0.4 (with & radiusTL .~ 0.2
--   >                                & radiusTR .~ -0.2
--   >                                & radiusBR .~ 0.1)
--   >   ]

roundedRect :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> n -> t
roundedRect :: forall n t.
(InSpace V2 n t, TrailLike t, RealFloat n) =>
n -> n -> n -> t
roundedRect n
w n
h n
r = n -> n -> RoundedRectOpts n -> t
forall n t.
(InSpace V2 n t, TrailLike t, RealFloat n) =>
n -> n -> RoundedRectOpts n -> t
roundedRect' n
w n
h (RoundedRectOpts n
forall a. Default a => a
def RoundedRectOpts n
-> (RoundedRectOpts n -> RoundedRectOpts n) -> RoundedRectOpts n
forall a b. a -> (a -> b) -> b
& (n -> Identity n)
-> RoundedRectOpts n -> Identity (RoundedRectOpts n)
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTL ((n -> Identity n)
 -> RoundedRectOpts n -> Identity (RoundedRectOpts n))
-> n -> RoundedRectOpts n -> RoundedRectOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
r
                                          RoundedRectOpts n
-> (RoundedRectOpts n -> RoundedRectOpts n) -> RoundedRectOpts n
forall a b. a -> (a -> b) -> b
& (n -> Identity n)
-> RoundedRectOpts n -> Identity (RoundedRectOpts n)
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBR ((n -> Identity n)
 -> RoundedRectOpts n -> Identity (RoundedRectOpts n))
-> n -> RoundedRectOpts n -> RoundedRectOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
r
                                          RoundedRectOpts n
-> (RoundedRectOpts n -> RoundedRectOpts n) -> RoundedRectOpts n
forall a b. a -> (a -> b) -> b
& (n -> Identity n)
-> RoundedRectOpts n -> Identity (RoundedRectOpts n)
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTR ((n -> Identity n)
 -> RoundedRectOpts n -> Identity (RoundedRectOpts n))
-> n -> RoundedRectOpts n -> RoundedRectOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
r
                                          RoundedRectOpts n
-> (RoundedRectOpts n -> RoundedRectOpts n) -> RoundedRectOpts n
forall a b. a -> (a -> b) -> b
& (n -> Identity n)
-> RoundedRectOpts n -> Identity (RoundedRectOpts n)
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBL ((n -> Identity n)
 -> RoundedRectOpts n -> Identity (RoundedRectOpts n))
-> n -> RoundedRectOpts n -> RoundedRectOpts n
forall s t a b. ASetter s t a b -> b -> s -> t
.~ n
r)

-- | @roundedRect'@ works like @roundedRect@ but allows you to set the radius of
--   each corner indivually, using @RoundedRectOpts@. The default corner radius is 0.
--   Each radius can also be negative, which results in the curves being reversed
--   to be inward instead of outward.
roundedRect' :: (InSpace V2 n t, TrailLike t, RealFloat n) => n -> n -> RoundedRectOpts n -> t
roundedRect' :: forall n t.
(InSpace V2 n t, TrailLike t, RealFloat n) =>
n -> n -> RoundedRectOpts n -> t
roundedRect' n
w n
h RoundedRectOpts n
opts
   = Located (Trail (V t) (N t)) -> t
Located (Trail V2 n) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike
   (Located (Trail V2 n) -> t)
-> (Trail' Line V2 n -> Located (Trail V2 n))
-> Trail' Line V2 n
-> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (n
wn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2, n -> n
forall a. Num a => a -> a
abs n
rBR n -> n -> n
forall a. Num a => a -> a -> a
- n
hn -> n -> n
forall a. Fractional a => a -> a -> a
/n
2))
   (Trail V2 n -> Located (Trail V2 n))
-> (Trail' Line V2 n -> Trail V2 n)
-> Trail' Line V2 n
-> Located (Trail V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Loop V2 n -> Trail V2 n
forall l (v :: * -> *) n. Trail' l v n -> Trail v n
wrapTrail
   (Trail' Loop V2 n -> Trail V2 n)
-> (Trail' Line V2 n -> Trail' Loop V2 n)
-> Trail' Line V2 n
-> Trail V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trail' Line V2 n -> Trail' Loop V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Line v n -> Trail' Loop v n
glueLine
   (Trail' Line V2 n -> t) -> Trail' Line V2 n -> t
forall a b. (a -> b) -> a -> b
$ (n, n) -> Trail' Line V2 n
seg (n
0, n
h n -> n -> n
forall a. Num a => a -> a -> a
- n -> n
forall a. Num a => a -> a
abs n
rTR n -> n -> n
forall a. Num a => a -> a -> a
- n -> n
forall a. Num a => a -> a
abs n
rBR)
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> N (Trail' Line V2 n) -> N (Trail' Line V2 n) -> Trail' Line V2 n
forall {a}.
(V a ~ V2, TrailLike a, RealFloat (N a), Monoid a) =>
N a -> N a -> a
mkCorner n
N (Trail' Line V2 n)
0 n
N (Trail' Line V2 n)
rTR
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> (n, n) -> Trail' Line V2 n
seg (n -> n
forall a. Num a => a -> a
abs n
rTR n -> n -> n
forall a. Num a => a -> a -> a
+ n -> n
forall a. Num a => a -> a
abs n
rTL n -> n -> n
forall a. Num a => a -> a -> a
- n
w, n
0)
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> N (Trail' Line V2 n) -> N (Trail' Line V2 n) -> Trail' Line V2 n
forall {a}.
(V a ~ V2, TrailLike a, RealFloat (N a), Monoid a) =>
N a -> N a -> a
mkCorner n
N (Trail' Line V2 n)
1 n
N (Trail' Line V2 n)
rTL
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> (n, n) -> Trail' Line V2 n
seg (n
0, n -> n
forall a. Num a => a -> a
abs n
rTL n -> n -> n
forall a. Num a => a -> a -> a
+ n -> n
forall a. Num a => a -> a
abs n
rBL n -> n -> n
forall a. Num a => a -> a -> a
- n
h)
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> N (Trail' Line V2 n) -> N (Trail' Line V2 n) -> Trail' Line V2 n
forall {a}.
(V a ~ V2, TrailLike a, RealFloat (N a), Monoid a) =>
N a -> N a -> a
mkCorner n
N (Trail' Line V2 n)
2 n
N (Trail' Line V2 n)
rBL
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> (n, n) -> Trail' Line V2 n
seg (n
w n -> n -> n
forall a. Num a => a -> a -> a
- n -> n
forall a. Num a => a -> a
abs n
rBL n -> n -> n
forall a. Num a => a -> a -> a
- n -> n
forall a. Num a => a -> a
abs n
rBR, n
0)
   Trail' Line V2 n -> Trail' Line V2 n -> Trail' Line V2 n
forall a. Semigroup a => a -> a -> a
<> N (Trail' Line V2 n) -> N (Trail' Line V2 n) -> Trail' Line V2 n
forall {a}.
(V a ~ V2, TrailLike a, RealFloat (N a), Monoid a) =>
N a -> N a -> a
mkCorner n
N (Trail' Line V2 n)
3 n
N (Trail' Line V2 n)
rBR
  where seg :: (n, n) -> Trail' Line V2 n
seg   = [V2 n] -> Trail' Line V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[v n] -> Trail' Line v n
lineFromOffsets ([V2 n] -> Trail' Line V2 n)
-> ((n, n) -> [V2 n]) -> (n, n) -> Trail' Line V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 n -> [V2 n] -> [V2 n]
forall a. a -> [a] -> [a]
:[]) (V2 n -> [V2 n]) -> ((n, n) -> V2 n) -> (n, n) -> [V2 n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n, n) -> V2 n
forall n. (n, n) -> V2 n
r2
        diag :: n
diag  = n -> n
forall a. Floating a => a -> a
sqrt (n
w n -> n -> n
forall a. Num a => a -> a -> a
* n
w n -> n -> n
forall a. Num a => a -> a -> a
+ n
h n -> n -> n
forall a. Num a => a -> a -> a
* n
h)
        -- to clamp corner radius, need to compare with other corners that share an
        -- edge. If the corners overlap then reduce the largest corner first, as far
        -- as 50% of the edge in question.
        rTL :: n
rTL                 = Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> n
clampCnr Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTR Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBL Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBR Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTL
        rBL :: n
rBL                 = Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> n
clampCnr Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBR Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTL Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTR Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBL
        rTR :: n
rTR                 = Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> n
clampCnr Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTL Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBR Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBL Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTR
        rBR :: n
rBR                 = Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> n
clampCnr Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBL Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTR Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusTL Getting n (RoundedRectOpts n) n
forall d (f :: * -> *).
Functor f =>
(d -> f d) -> RoundedRectOpts d -> f (RoundedRectOpts d)
radiusBR
        clampCnr :: Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> Getting n (RoundedRectOpts n) n
-> n
clampCnr Getting n (RoundedRectOpts n) n
rx Getting n (RoundedRectOpts n) n
ry Getting n (RoundedRectOpts n) n
ro Getting n (RoundedRectOpts n) n
r = let (n
rx',n
ry',n
ro',n
r') = (RoundedRectOpts n
optsRoundedRectOpts n -> Getting n (RoundedRectOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (RoundedRectOpts n) n
rx, RoundedRectOpts n
optsRoundedRectOpts n -> Getting n (RoundedRectOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (RoundedRectOpts n) n
ry, RoundedRectOpts n
optsRoundedRectOpts n -> Getting n (RoundedRectOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (RoundedRectOpts n) n
ro, RoundedRectOpts n
optsRoundedRectOpts n -> Getting n (RoundedRectOpts n) n -> n
forall s a. s -> Getting a s a -> a
^.Getting n (RoundedRectOpts n) n
r)
                                in n -> n -> n
clampDiag n
ro' (n -> n) -> (n -> n) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n -> n -> n
forall {a}. (Ord a, Fractional a) => a -> a -> a -> a
clampAdj n
h n
ry' (n -> n) -> (n -> n) -> n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n -> n -> n
forall {a}. (Ord a, Fractional a) => a -> a -> a -> a
clampAdj n
w n
rx' (n -> n) -> n -> n
forall a b. (a -> b) -> a -> b
$ n
r'
        -- prevent curves of adjacent corners from overlapping
        clampAdj :: a -> a -> a -> a
clampAdj a
len a
adj a
r  = if a -> a
forall a. Num a => a -> a
abs a
r a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
lena -> a -> a
forall a. Fractional a => a -> a -> a
/a
2
                                then a -> a
forall {a} {a}. (Ord a, Num a, Num a) => a -> a
sign a
r a -> a -> a
forall a. Num a => a -> a -> a
* a -> a -> a
forall a. Ord a => a -> a -> a
max (a
lena -> a -> a
forall a. Fractional a => a -> a -> a
/a
2) (a -> a -> a
forall a. Ord a => a -> a -> a
min (a
len a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall a. Num a => a -> a
abs a
adj) (a -> a
forall a. Num a => a -> a
abs a
r))
                                else a
r
        -- prevent inward curves of diagonally opposite corners from intersecting
        clampDiag :: n -> n -> n
clampDiag n
opp n
r     = if n
r n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0 Bool -> Bool -> Bool
&& n
opp n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0 Bool -> Bool -> Bool
&& n -> n
forall a. Num a => a -> a
abs n
r n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
diag n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2
                                then n -> n
forall {a} {a}. (Ord a, Num a, Num a) => a -> a
sign n
r n -> n -> n
forall a. Num a => a -> a -> a
* n -> n -> n
forall a. Ord a => a -> a -> a
max (n
diag n -> n -> n
forall a. Fractional a => a -> a -> a
/ n
2) (n -> n -> n
forall a. Ord a => a -> a -> a
min (n -> n
forall a. Num a => a -> a
abs n
r) (n
diag n -> n -> n
forall a. Num a => a -> a -> a
+ n
opp))
                                else n
r
        sign :: a -> a
sign a
n = if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then -a
1 else a
1
        mkCorner :: N a -> N a -> a
mkCorner N a
k N a
r | N a
r N a -> N a -> Bool
forall a. Eq a => a -> a -> Bool
== N a
0    = a
forall a. Monoid a => a
mempty
                     | N a
r N a -> N a -> Bool
forall a. Ord a => a -> a -> Bool
< N a
0     = N a -> N a -> a
doArc N a
3 (-N a
1)
                     | Bool
otherwise = N a -> N a -> a
doArc N a
0 N a
1
                     where
                       doArc :: N a -> N a -> a
doArc N a
d N a
s =
                           N a -> Direction V2 (N a) -> Angle (N a) -> a
forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
n -> Direction V2 n -> Angle n -> t
arc' N a
r (Direction V2 (N a)
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir Direction V2 (N a)
-> (Direction V2 (N a) -> Direction V2 (N a)) -> Direction V2 (N a)
forall a b. a -> (a -> b) -> b
& (Angle (N a) -> Identity (Angle (N a)))
-> Direction V2 (N a) -> Identity (Direction V2 (N a))
forall n. RealFloat n => Lens' (Direction V2 n) (Angle n)
Lens' (Direction V2 (N a)) (Angle (N a))
forall (t :: * -> *) n.
(HasTheta t, RealFloat n) =>
Lens' (t n) (Angle n)
_theta ((Angle (N a) -> Identity (Angle (N a)))
 -> Direction V2 (N a) -> Identity (Direction V2 (N a)))
-> Angle (N a) -> Direction V2 (N a) -> Direction V2 (N a)
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ ((N a
kN a -> N a -> N a
forall a. Num a => a -> a -> a
+N a
d)N a -> N a -> N a
forall a. Fractional a => a -> a -> a
/N a
4 N a -> AReview (Angle (N a)) (N a) -> Angle (N a)
forall b a. b -> AReview a b -> a
@@ AReview (Angle (N a)) (N a)
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle (N a)) (N a)
turn)) (N a
sN a -> N a -> N a
forall a. Fractional a => a -> a -> a
/N a
4 N a -> AReview (Angle (N a)) (N a) -> Angle (N a)
forall b a. b -> AReview a b -> a
@@ AReview (Angle (N a)) (N a)
forall n. Floating n => Iso' (Angle n) n
Iso' (Angle (N a)) (N a)
turn)