{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}
{-# OPTIONS_GHC -fno-warn-unused-imports       #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Arrowheads
-- Copyright   :  (c) 2013 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Standard arrowheads and tails. Each arrowhead or tail is designed
-- to be drawn filled, with a line width of 0, and is normalized to
-- fit inside a circle of diameter 1.
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Arrowheads
       (
       -- * Arrowheads
       -- ** Standard arrowheads
         tri
       , dart
       , halfDart
       , spike
       , thorn
       , lineHead
       , noHead

       -- ** Configurable arrowheads
       -- | Creates arrowheads of the same shape as the standard heads but
       --   where the angle parameter is used to specify the angle to the top
       --   left point of the arrowhead.
       , arrowheadTriangle
       , arrowheadDart
       , arrowheadHalfDart
       , arrowheadSpike
       , arrowheadThorn

       -- * Arrow tails
       -- ** Standard arrow tails
       , tri'
       , dart'
       , halfDart'
       , spike'
       , thorn'
       , lineTail
       , noTail
       , quill
       , block

       -- ** Configurable arrow tails

       , arrowtailQuill
       , arrowtailBlock

       -- * Internals
       , ArrowHT
       ) where

import           Control.Lens            ((&), (.~), (<>~), (^.))
import           Data.Default.Class
import           Data.Monoid             (mempty, (<>))

import           Diagrams.Angle
import           Diagrams.Core

import           Diagrams.Path
import           Diagrams.Segment
import           Diagrams.Trail
import           Diagrams.TrailLike      (fromOffsets)
import           Diagrams.TwoD.Align
import           Diagrams.TwoD.Arc       (arc')
import           Diagrams.TwoD.Path      ()
import           Diagrams.TwoD.Polygons
import           Diagrams.TwoD.Shapes
import           Diagrams.TwoD.Transform
import           Diagrams.TwoD.Types
import           Diagrams.TwoD.Vector    (unitX, unit_X, xDir)
import           Diagrams.Util           (( # ))

import           Linear.Affine
import           Linear.Metric
import           Linear.Vector

-----------------------------------------------------------------------------

type ArrowHT n = n -> n -> (Path V2 n, Path V2 n)

closedPath :: OrderedField n => Trail V2 n -> Path V2 n
closedPath :: forall n. OrderedField n => Trail V2 n -> Path V2 n
closedPath = forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail

-- Heads ------------------------------------------------------------------
--   > drawHead h = arrowAt' (with & arrowHead .~ h & shaftStyle %~ lw none
--   >                             & headLength .~ local 0.5)
--   >         origin (r2 (1, 0))
--   >      <> square 0.5 # alignL # lw none # frame 0.1

-- | Isoceles triangle style. The above example specifies an angle of `2/5 Turn`.

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg#diagram=tri25Ex&width=120>>

--   > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 @@ turn)
--   >                          & shaftStyle %~ lw none & headLength .~ local 0.5)
--   >           origin (r2 (0.5, 0))
--   >        <> square 0.6 # alignL # lw none # frame 0.1
arrowheadTriangle :: RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle Angle n
theta = n -> n -> (Path V2 n, Path V2 n)
aHead
  where
    aHead :: n -> n -> (Path V2 n, Path V2 n)
aHead n
len n
_ = (Path V2 n
p, forall a. Monoid a => a
mempty)
      where
        psi :: n
psi = forall a. Floating a => a
pi forall a. Num a => a -> a -> a
- (Angle n
theta forall s a. s -> Getting a s a -> a
^. forall n. Iso' (Angle n) n
rad)
        r :: n
r = n
len forall a. Fractional a => a -> a -> a
/ (n
1 forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
cos n
psi)
        p :: Path V2 n
p = forall n t. (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon (forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall n. Lens' (PolygonOpts n) (PolyType n)
polyType forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall n. [Angle n] -> [n] -> PolyType n
PolyPolar [Angle n
theta, (-n
2) forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Angle n
theta]
            (forall a. a -> [a]
repeat n
r) forall a b. a -> (a -> b) -> b
& forall n. Lens' (PolygonOpts n) (PolyOrientation n)
polyOrient forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall n. PolyOrientation n
NoOrient)  forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignL


-- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like.
arrowheadDart :: RealFloat n => Angle n -> ArrowHT n
arrowheadDart :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadDart Angle n
theta n
len n
shaftWidth = (Path V2 n
hd forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
sz, Path V2 n
jt)
  where
    hd :: Path V2 n
hd = forall n a.
(InSpace V2 n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
a -> a
snugL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Trail v n
glueTrail forall a b. (a -> b) -> a -> b
$ forall t. TrailLike t => [Vn t] -> t
fromOffsets [V2 n
t1, V2 n
t2, V2 n
b2, V2 n
b1]
    jt :: Path V2 n
jt = forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Trail v n
glueTrail forall a b. (a -> b) -> a -> b
$ Trail V2 n
j forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY Trail V2 n
j
    j :: Trail V2 n
j = forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail forall a b. (a -> b) -> a -> b
$ forall t. TrailLike t => [Vn t] -> t
fromOffsets [forall a. a -> a -> V2 a
V2 (-n
jLength) n
0, forall a. a -> a -> V2 a
V2 n
0 (n
shaftWidth forall a. Fractional a => a -> a -> a
/ n
2)]
    v :: V2 n
v = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
    (V2 n
t1, V2 n
t2) = (forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
v, forall a. a -> a -> V2 a
V2 (-n
0.5) n
0 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ V2 n
v)
    [V2 n
b1, V2 n
b2] = forall a b. (a -> b) -> [a] -> [b]
map (forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated) [V2 n
t1, V2 n
t2]
    psi :: n
psi = forall a. Floating a => a
pi forall a. Num a => a -> a -> a
- forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated V2 n
t2 forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) n.
(HasTheta t, RealFloat n) =>
Lens' (t n) (Angle n)
_theta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Iso' (Angle n) n
rad
    jLength :: n
jLength = n
shaftWidth forall a. Fractional a => a -> a -> a
/ (n
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
tan n
psi)

    -- If the shaft is too wide, set the size to a default value of 1.
    sz :: n
sz = forall a. Ord a => a -> a -> a
max n
1 ((n
len forall a. Num a => a -> a -> a
- n
jLength) forall a. Fractional a => a -> a -> a
/ n
1.5)

-- | Top half of an 'arrowheadDart'.
arrowheadHalfDart :: RealFloat n => Angle n -> ArrowHT n
arrowheadHalfDart :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadHalfDart Angle n
theta n
len n
shaftWidth = (Path V2 n
hd, Path V2 n
jt)
  where
    hd :: Path V2 n
hd = forall t. TrailLike t => [Vn t] -> t
fromOffsets [V2 n
t1, V2 n
t2]
       # closeTrail # pathFromTrail
       # translateX 1.5 # scale sz
       # translateY (-shaftWidth/2)
       # snugL
    jt :: Path V2 n
jt = forall n a.
(InSpace V2 n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
a -> a
snugR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
n -> t -> t
translateY (-n
shaftWidthforall a. Fractional a => a -> a -> a
/n
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail forall a b. (a -> b) -> a -> b
$ forall t. TrailLike t => [Vn t] -> t
fromOffsets [forall a. a -> a -> V2 a
V2 (-n
jLength) n
0, forall a. a -> a -> V2 a
V2 n
0 n
shaftWidth]
    v :: V2 n
v = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
    (V2 n
t1, V2 n
t2) = (forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
v, (n
0.5 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X) forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ V2 n
v)
    psi :: n
psi = forall a. Floating a => a
pi forall a. Num a => a -> a -> a
- forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated V2 n
t2 forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) n.
(HasTheta t, RealFloat n) =>
Lens' (t n) (Angle n)
_theta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Iso' (Angle n) n
rad
    jLength :: n
jLength = n
shaftWidth forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a -> a
tan n
psi

    -- If the shaft is too wide, set the size to a default value of 1.
    sz :: n
sz = forall a. Ord a => a -> a -> a
max n
1 ((n
len forall a. Num a => a -> a -> a
- n
jLength) forall a. Fractional a => a -> a -> a
/ n
1.5)

-- | Isoceles triangle with curved concave base. Inkscape type 2.
arrowheadSpike :: RealFloat n => Angle n -> ArrowHT n
arrowheadSpike :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadSpike Angle n
theta n
len n
shaftWidth  = (Path V2 n
hd forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
r, Path V2 n
jt forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
r)
  where
    hd :: Path V2 n
hd = forall n a.
(InSpace V2 n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
a -> a
snugL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. OrderedField n => Trail V2 n -> Path V2 n
closedPath forall a b. (a -> b) -> a -> b
$ Trail V2 n
l1 forall a. Semigroup a => a -> a -> a
<> Trail V2 n
c forall a. Semigroup a => a -> a -> a
<> Trail V2 n
l2
    jt :: Path V2 n
jt = forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n a.
(InSpace v n a, R2 v, Fractional n, Alignable a, HasOrigin a) =>
a -> a
centerY forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail forall a b. (a -> b) -> a -> b
$ forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
n -> Direction V2 n -> Angle n -> t
arc' n
1 (forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) n.
(HasTheta t, RealFloat n) =>
Lens' (t n) (Angle n)
_theta forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
phi) (n
2 forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Angle n
phi)
    l1 :: Trail V2 n
l1 = forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments [forall (v :: * -> *) n. v n -> Segment Closed v n
straight forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
v]
    l2 :: Trail V2 n
l2 = forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments [forall n (v :: * -> *).
(Num n, Additive v) =>
Segment Closed v n -> Segment Closed v n
reverseSegment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. v n -> Segment Closed v n
straight forall a b. (a -> b) -> a -> b
$ (forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY V2 n
v)]
    c :: Trail V2 n
c = forall n t.
(InSpace V2 n t, OrderedField n, TrailLike t) =>
n -> Direction V2 n -> Angle n -> t
arc' n
1 (forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
α forall (v :: * -> *) n. (R1 v, Additive v, Num n) => Direction v n
xDir) ((-n
2) forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Angle n
α)
    α :: Angle n
α = (n
1forall a. Fractional a => a -> a -> a
/n
2 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn) forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Angle n
theta
    v :: V2 n
v = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX

    -- The length of the head without its joint is, -2r cos theta and
    -- the length of the joint is r - sqrt (r^2 - y^2). So the total
    -- length of the arrow head is given by r(1 - 2 cos theta)-sqrt (r^2-y^2).
    -- Solving the quadratic gives two roots, we want the larger one.

    -- 1/4 turn < theta < 2/3 turn.
    a :: n
a = n
1 forall a. Num a => a -> a -> a
- n
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
cos (Angle n
theta forall s a. s -> Getting a s a -> a
^. forall n. Iso' (Angle n) n
rad)
    y :: n
y = n
shaftWidth forall a. Fractional a => a -> a -> a
/ n
2

    -- If the shaft is too wide for the head, we default the radius r to
    -- 2/3 * len by setting d=1 and phi=pi/2.
    d :: n
d = forall a. Ord a => a -> a -> a
max n
1 (n
lenforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
+ (n
1 forall a. Num a => a -> a -> a
- n
aforall a. Floating a => a -> a -> a
**n
2) forall a. Num a => a -> a -> a
* n
yforall a. Floating a => a -> a -> a
**n
2)
    r :: n
r = (n
a forall a. Num a => a -> a -> a
* n
len forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sqrt n
d) forall a. Fractional a => a -> a -> a
/ (n
aforall a. Floating a => a -> a -> a
**n
2 forall a. Num a => a -> a -> a
-n
1)
    phi :: Angle n
phi = forall n. Floating n => n -> Angle n
asinA (forall a. Ord a => a -> a -> a
min n
1 (n
yforall a. Fractional a => a -> a -> a
/n
r))

-- | Curved sides, linear concave base. Illustrator CS5 #3
arrowheadThorn :: RealFloat n => Angle n -> ArrowHT n
arrowheadThorn :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadThorn Angle n
theta n
len n
shaftWidth = (Path V2 n
hd forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
sz, Path V2 n
jt)
  where
    hd :: Path V2 n
hd = forall n a.
(InSpace V2 n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
a -> a
snugL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Trail v n
glueTrail forall a b. (a -> b) -> a -> b
$ Trail V2 n
hTop forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY Trail V2 n
hTop
    hTop :: Trail V2 n
hTop = forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Segment Closed v n] -> Trail v n
trailFromSegments forall a b. (a -> b) -> a -> b
$ [Segment Closed V2 n
c, Segment Closed V2 n
l]
    jt :: Path V2 n
jt = forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Path v n
pathFromTrail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail v n -> Trail v n
glueTrail forall a b. (a -> b) -> a -> b
$ Trail V2 n
j forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY Trail V2 n
j
    j :: Trail V2 n
j = forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail forall a b. (a -> b) -> a -> b
$ forall t. TrailLike t => [Vn t] -> t
fromOffsets [forall a. a -> a -> V2 a
V2 (-n
jLength) n
0, forall a. a -> a -> V2 a
V2 n
0 (n
shaftWidth forall a. Fractional a => a -> a -> a
/ n
2)]
    c :: Segment Closed V2 n
c = forall n. Floating n => Angle n -> Segment Closed V2 n
curvedSide Angle n
theta
    v :: V2 n
v = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
    l :: Segment Closed V2 n
l = forall n (v :: * -> *).
(Num n, Additive v) =>
Segment Closed v n -> Segment Closed v n
reverseSegment forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n. v n -> Segment Closed v n
straight forall a b. (a -> b) -> a -> b
$ V2 n
t
    t :: V2 n
t = V2 n
v forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ forall a. a -> a -> V2 a
V2 (-n
0.5) n
0
    psi :: Angle n
psi = forall v. Floating v => Angle v
fullTurn forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ n
2 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated V2 n
t forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) n.
(HasTheta t, RealFloat n) =>
Lens' (t n) (Angle n)
_theta)
    jLength :: n
jLength = n
shaftWidth forall a. Fractional a => a -> a -> a
/ (n
2 forall a. Num a => a -> a -> a
* forall n. Floating n => Angle n -> n
tanA Angle n
psi)

    -- If the shaft if too wide, set the size to a default value of 1.
    sz :: n
sz = forall a. Ord a => a -> a -> a
max n
1 ((n
len forall a. Num a => a -> a -> a
- n
jLength) forall a. Fractional a => a -> a -> a
/ n
1.5)

-- | Make a side for the thorn head.
curvedSide :: Floating n => Angle n -> Segment Closed V2 n
curvedSide :: forall n. Floating n => Angle n -> Segment Closed V2 n
curvedSide Angle n
theta = forall (v :: * -> *) n. v n -> v n -> v n -> Segment Closed v n
bezier3 forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
ctrl1 V2 n
ctrl2 V2 n
end
  where
    v0 :: v n
v0    = forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unit_X
    v1 :: V2 n
v1    = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
    ctrl1 :: v n
ctrl1 = forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
v0
    ctrl2 :: V2 n
ctrl2 = forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
v0 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
v1
    end :: V2 n
end   = forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
v0 forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ V2 n
v1

-- Standard heads ---------------------------------------------------------
-- | A line the same width as the shaft.
lineHead :: RealFloat n => ArrowHT n
lineHead :: forall n. RealFloat n => ArrowHT n
lineHead n
s n
w = (forall n t. (InSpace V2 n t, TrailLike t) => n -> t
square n
1 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX n
s forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY n
w forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignL, forall a. Monoid a => a
mempty)

noHead :: ArrowHT n
noHead :: forall n. ArrowHT n
noHead n
_ n
_ = (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg#diagram=triEx&width=100>>

--   > triEx = drawHead tri
tri :: RealFloat n => ArrowHT n
tri :: forall n. RealFloat n => ArrowHT n
tri = forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadTriangle (n
1forall a. Fractional a => a -> a -> a
/n
3 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg#diagram=spikeEx&width=100>>

--   > spikeEx = drawHead spike
spike :: RealFloat n => ArrowHT n
spike :: forall n. RealFloat n => ArrowHT n
spike = forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadSpike (n
3forall a. Fractional a => a -> a -> a
/n
8 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg#diagram=thornEx&width=100>>

--   > thornEx = drawHead thorn
thorn :: RealFloat n => ArrowHT n
thorn :: forall n. RealFloat n => ArrowHT n
thorn = forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadThorn (n
3forall a. Fractional a => a -> a -> a
/n
8 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg#diagram=dartEx&width=100>>

--   > dartEx = drawHead dart
dart :: RealFloat n => ArrowHT n
dart :: forall n. RealFloat n => ArrowHT n
dart = forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadDart (n
2forall a. Fractional a => a -> a -> a
/n
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg#diagram=halfDartEx&width=100>>

--   > halfDartEx = drawHead halfDart
halfDart :: RealFloat n => ArrowHT n
halfDart :: forall n. RealFloat n => ArrowHT n
halfDart = forall n. RealFloat n => Angle n -> ArrowHT n
arrowheadHalfDart (n
2forall a. Fractional a => a -> a -> a
/n
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- Tails ------------------------------------------------------------------
--   > drawTail t = arrowAt' (with  & arrowTail .~ t & shaftStyle %~ lw none
--   >                              & arrowHead .~ noHead & tailLength .~ local 0.5)
--   >         origin (r2 (1, 0))
--   >      <> square 0.5 # alignL # lw none # frame 0.1

-- | Utility function to convert any arrowhead to an arrowtail, i.e.
--   attached at the start of the trail.
headToTail :: OrderedField n => ArrowHT n -> ArrowHT n
headToTail :: forall n. OrderedField n => ArrowHT n -> ArrowHT n
headToTail ArrowHT n
hd = ArrowHT n
tl
  where
    tl :: ArrowHT n
tl n
sz n
shaftWidth = (Path V2 n
t, Path V2 n
j)
      where
        (Path V2 n
t', Path V2 n
j') = ArrowHT n
hd n
sz n
shaftWidth
        t :: Path V2 n
t = forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
t -> t
reflectX Path V2 n
t'
        j :: Path V2 n
j = forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
t -> t
reflectX Path V2 n
j'

arrowtailBlock :: forall n. (RealFloat n) => Angle n -> ArrowHT n
arrowtailBlock :: forall n. RealFloat n => Angle n -> ArrowHT n
arrowtailBlock Angle n
theta = n -> n -> (Path V2 n, Path V2 n)
aTail
  where
   aTail :: n -> n -> (Path V2 n, Path V2 n)
aTail n
len n
_ = (Path V2 n
t, forall a. Monoid a => a
mempty)
      where
        t :: Path V2 n
t  = forall n t. (InSpace V2 n t, TrailLike t) => n -> n -> t
rect n
len (n
len forall a. Num a => a -> a -> a
* n
x) forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignR
        a' :: V2 n
        a' :: V2 n
a' = forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX
        a :: V2 n
a  = V2 n
a' forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY V2 n
a'
        x :: n
x  = forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm V2 n
a

-- | The angle is where the top left corner intersects the circle.
arrowtailQuill :: OrderedField n => Angle n -> ArrowHT n
arrowtailQuill :: forall n. OrderedField n => Angle n -> ArrowHT n
arrowtailQuill Angle n
theta = n -> n -> (Path V2 n, Path V2 n)
aTail
  where
   aTail :: n -> n -> (Path V2 n, Path V2 n)
aTail n
len n
shaftWidth = (Path V2 n
t, Path V2 n
j)
      where
        t :: Path V2 n
t = forall n. OrderedField n => Trail V2 n -> Path V2 n
closedPath (forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Point v n] -> Trail v n
trailFromVertices [forall {n}. Fractional n => P2 n
v0, Point V2 n
v1, Point V2 n
v2, forall {n}. Fractional n => P2 n
v3, Point V2 n
v4, Point V2 n
v5, forall {n}. Fractional n => P2 n
v0])
              # scale sz # alignR
        sz :: n
sz = n
len forall a. Fractional a => a -> a -> a
/ n
0.6
        v0 :: P2 n
v0 = forall n. (n, n) -> P2 n
p2 (n
0.5, n
0)
        v2 :: Point V2 n
v2 = forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
theta forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
0.5)
        v1 :: Point V2 n
v1 = Point V2 n
v2 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX (n
5forall a. Fractional a => a -> a -> a
/n
8)
        v3 :: P2 n
v3 = forall n. (n, n) -> P2 n
p2 (-n
0.1, n
0)
        v4 :: Point V2 n
v4 = Point V2 n
v2 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY
        v5 :: Point V2 n
v5 = Point V2 n
v4 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R1 v, Transformable t) =>
n -> t -> t
translateX (n
5forall a. Fractional a => a -> a -> a
/n
8)
        s :: n
s = n
1 forall a. Num a => a -> a -> a
- n
shaftWidth forall a. Fractional a => a -> a -> a
/ forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Point V2 n
v1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
v5)
        n1 :: Point V2 n
n1 = forall {n}. Fractional n => P2 n
v0 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
n -> t -> t
translateY (n
0.5 forall a. Num a => a -> a -> a
* n
shaftWidth)
        n2 :: Point V2 n
n2 = Point V2 n
v1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ ((Point V2 n
v1 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall {n}. Fractional n => P2 n
v0) forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
s)
        n3 :: Point V2 n
n3 = Point V2 n
v5 forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ ((Point V2 n
v5 forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall {n}. Fractional n => P2 n
v0) forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
s)
        n4 :: Point V2 n
n4 = Point V2 n
n1 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY
        j :: Path V2 n
j  = forall n. OrderedField n => Trail V2 n -> Path V2 n
closedPath forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Point v n] -> Trail v n
trailFromVertices [forall {n}. Fractional n => P2 n
v0, Point V2 n
n1, Point V2 n
n2, forall {n}. Fractional n => P2 n
v0, Point V2 n
n3, Point V2 n
n4, forall {n}. Fractional n => P2 n
v0]

-- Standard tails ---------------------------------------------------------
-- | A line the same width as the shaft.
lineTail :: RealFloat n => ArrowHT n
lineTail :: forall n. RealFloat n => ArrowHT n
lineTail n
s n
w = (forall n t. (InSpace V2 n t, TrailLike t) => n -> t
square n
1 forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleY n
w forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Fractional n, Transformable t) =>
n -> t -> t
scaleX n
s forall a b. a -> (a -> b) -> b
# forall n a.
(InSpace V2 n a, Fractional n, Alignable a, HasOrigin a) =>
a -> a
alignR, forall a. Monoid a => a
mempty)

noTail :: ArrowHT n
noTail :: forall n. ArrowHT n
noTail n
_ n
_ = (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg#diagram=tri'Ex&width=100>>

--   > tri'Ex = drawTail tri'
tri' :: RealFloat n => ArrowHT n
tri' :: forall n. RealFloat n => ArrowHT n
tri' = forall n. OrderedField n => ArrowHT n -> ArrowHT n
headToTail forall n. RealFloat n => ArrowHT n
tri

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg#diagram=spike'Ex&width=100>>

--   > spike'Ex = drawTail spike'
spike' :: RealFloat n => ArrowHT n
spike' :: forall n. RealFloat n => ArrowHT n
spike' = forall n. OrderedField n => ArrowHT n -> ArrowHT n
headToTail forall n. RealFloat n => ArrowHT n
spike

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg#diagram=thorn'Ex&width=100>>

--   > thorn'Ex = drawTail thorn'
thorn' :: RealFloat n => ArrowHT n
thorn' :: forall n. RealFloat n => ArrowHT n
thorn' = forall n. OrderedField n => ArrowHT n -> ArrowHT n
headToTail forall n. RealFloat n => ArrowHT n
thorn

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg#diagram=dart'Ex&width=100>>

--   > dart'Ex = drawTail dart'
dart' :: RealFloat n => ArrowHT n
dart' :: forall n. RealFloat n => ArrowHT n
dart' = forall n. OrderedField n => ArrowHT n -> ArrowHT n
headToTail forall n. RealFloat n => ArrowHT n
dart

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg#diagram=halfDart'Ex&width=100>>

--   > halfDart'Ex = drawTail halfDart'
halfDart' :: RealFloat n => ArrowHT n
halfDart' :: forall n. RealFloat n => ArrowHT n
halfDart' = forall n. OrderedField n => ArrowHT n -> ArrowHT n
headToTail forall n. RealFloat n => ArrowHT n
halfDart

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg#diagram=quillEx&width=100>>

--   > quillEx = drawTail quill
quill :: (Floating n, Ord n) => ArrowHT n
quill :: forall n. (Floating n, Ord n) => ArrowHT n
quill = forall n. OrderedField n => Angle n -> ArrowHT n
arrowtailQuill (n
2forall a. Fractional a => a -> a -> a
/n
5 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)

-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg#diagram=blockEx&width=100>>

--   > blockEx = drawTail block
block :: RealFloat n => ArrowHT n
block :: forall n. RealFloat n => ArrowHT n
block = forall n. RealFloat n => Angle n -> ArrowHT n
arrowtailBlock (n
7forall a. Fractional a => a -> a -> a
/n
16 forall b a. b -> AReview a b -> a
@@ forall n. Floating n => Iso' (Angle n) n
turn)