diagrams-lib-1.0: src/Diagrams/TwoD/Arrowheads.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- 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
, spike
, thorn
, missile
, 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
, arrowheadSpike
, arrowheadThorn
, arrowheadMissile
-- * Arrow tails
-- ** Standard arrow tails
, tri'
, dart'
, spike'
, thorn'
, missile'
, noTail
, quill
, block
-- ** Configurable arrow tails
, arrowtailQuill
, arrowtailBlock
-- * Internals
, ArrowHT
) where
import Control.Lens ((&), (.~))
import Data.Default.Class
import Data.AffineSpace
import Data.Functor ((<$>))
import Data.Maybe (fromMaybe)
import Data.Monoid (mempty, (<>))
import Data.VectorSpace
import Diagrams.Core
import Diagrams.CubicSpline (cubicSpline)
import Diagrams.Path
import Diagrams.Segment
import Diagrams.Trail
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 (e, unitX, unit_X)
import Diagrams.Util (( # ))
-----------------------------------------------------------------------------
type ArrowHT = Double -> Double -> (Path R2, Path R2)
htRadius :: Double
htRadius = 0.5
scaleR :: (Transformable t, Scalar (V t) ~ Double) => t -> t
scaleR = scale htRadius
unit_X2 :: R2
unit_X2 = scaleR unit_X
closedPath :: (Floating (Scalar v), Ord (Scalar v), InnerSpace v) => Trail v -> Path v
closedPath = pathFromTrail . closeTrail
-- Heads ------------------------------------------------------------------
-- > drawHead h = arrowAt' (with & arrowHead .~ h & shaftStyle %~ lw 0)
-- > origin (r2 (0.001, 0))
-- > <> square 0.5 # alignL # lw 0
-- | 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 0)
-- > origin (r2 (0.001, 0))
-- > <> square 0.6 # alignL # lw 0
arrowheadTriangle :: Angle a => a -> ArrowHT
arrowheadTriangle theta = aHead
where
aHead size _ = (p, mempty)
where
p = polygon (def & polyType .~ PolyPolar [theta, (-2 * theta)]
(repeat (htRadius * size)) & polyOrient .~ NoOrient) # alignL
-- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like.
arrowheadDart :: Angle a => a -> ArrowHT
arrowheadDart theta = aHead
where
aHead size shaftWidth = (dartP # moveOriginTo (dartVertices !! 2), joint)
where
a = toTurn theta
r = htRadius * size
dartP = polygon (def & polyType .~ PolyPolar [a, 1/2 - a, 1/2 - a]
[r, r, 0.1 * size, r] & polyOrient .~ NoOrient)
dartVertices = (concat . pathVertices) $ dartP
m = magnitude (dartVertices !! 1 .-. dartVertices !! 3)
s = 1 - shaftWidth / m
v1 = (dartVertices !! 1 .-. dartVertices !! 2) # scale s
v2 = (dartVertices !! 3 .-. dartVertices !! 2) # scale s
joint = (closedPath $ trailFromVertices [ dartVertices !! 2
, dartVertices !! 1 .-^ v1
, dartVertices !! 3 .-^ v2
, dartVertices !! 2 ]) # alignR
-- | Isoceles triangle with curved concave base. Inkscape type 2.
arrowheadSpike :: Angle a => a -> ArrowHT
arrowheadSpike theta = aHead
where
aHead size shaftWidth = (barb # moveOriginBy (m *^ unit_X) , joint)
where
a = e theta # scaleR
a' = reflectY a
l1 = trailFromSegments [straight (unit_X2 ^+^ a)]
l2 = trailFromSegments [reverseSegment . straight $ (unit_X2 ^+^ a')]
c = reflectX $ arc' htRadius theta (-theta)
barb = (closedPath $ (l1 <> c <> l2)) # scale size
m = xWidth barb --c `atParam` 0.5
b = Rad $ asin ((shaftWidth / 2) / (htRadius * size))
c' = arc' htRadius (-b ) b # scale size
joint = (closedPath $ (c')) # centerY # alignR
xWidth p = pa + pb
where
pa = fromMaybe 0 (magnitude <$> traceV origin unitX p)
pb = fromMaybe 0 (magnitude <$> traceV origin unit_X p)
-- | Curved sides, linear concave base. Illustrator CS5 #3
arrowheadThorn :: Angle a => a -> Double -> ArrowHT
arrowheadThorn theta r = aHead
where
aHead size shaftWidth = (thornP # moveOriginTo (thornVertices !! 2), joint)
where
a = e theta # scaleR
c1 = curvedSide theta
l1 = straight $ (reflectY a) ^-^ (unit_X2 # scale r)
l2 = straight $ unit_X2 # scale r ^-^ a
c2 = c1 # rotate (-theta)
thornP = (closedPath $ trailFromSegments [c1, l1, l2, c2]) # scale size
thornVertices = (concat . pathVertices) $ thornP
m = magnitude (thornVertices !! 1 .-. thornVertices !! 3)
s = 1 - shaftWidth / m
v1 = (thornVertices !! 1 .-. thornVertices !! 2) # scale s
v2 = (thornVertices !! 3 .-. thornVertices !! 2) # scale s
joint = (closedPath $ trailFromVertices [ thornVertices !! 2
, thornVertices !! 1 .-^ v1
, thornVertices !! 3 .-^ v2
, thornVertices !! 2 ]) # alignR
-- | Make a side for the thorn head.
curvedSide :: Angle a => a -> Segment Closed R2
curvedSide theta = bezier3 ctrl1 ctrl2 end
where
v0 = scaleR unit_X
v1 = e theta # scaleR
ctrl1 = v0 # scaleR
ctrl2 = v0 ^+^ (v1 # scaleR)
end = v0 ^+^ v1
-- | Transform an arrowhead/tail by fitting a cubic spline to it's vertices.
-- XXX Rear vertices of the arrowhead will extend outside of the unit circle.
-- XXX and the joint is a rectancgle as opposed to the correct shape.
smoothArrowhead :: ArrowHT -> ArrowHT
smoothArrowhead f = aHead
where
aHead size shaftWidth = (h, j)
where
(h', _) = f size shaftWidth
h = smooth $ pathVertices h'
-- XXX replace square joint with actual shape
j = square shaftWidth # scaleX 0.25 alignR
smooth [] = mempty
smooth (x:xs) = cubicSpline True x <> smooth xs
arrowheadMissile :: Angle a => a -> ArrowHT
arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta
-- Standard heads ---------------------------------------------------------
noHead :: ArrowHT
noHead _ _ = (mempty, mempty)
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg#diagram=triEx&width=100>>
-- > triEx = drawHead tri
tri :: ArrowHT
tri = arrowheadTriangle (1/3 :: Turn)
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg#diagram=spikeEx&width=100>>
-- > spikeEx = drawHead spike
spike :: ArrowHT
spike = arrowheadSpike (3/8 :: Turn)
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg#diagram=thornEx&width=100>>
-- > thornEx = drawHead thorn
thorn :: ArrowHT
thorn = arrowheadThorn (3/8 :: Turn) 1
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg#diagram=dartEx&width=100>>
-- > dartEx = drawHead dart
dart :: ArrowHT
dart = arrowheadDart (2/5 :: Turn)
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_missileEx.svg#diagram=missileEx&width=100>>
-- > missileEx = drawHead missile
missile :: ArrowHT
missile = arrowheadMissile (2/5 :: Turn)
-- Tails ------------------------------------------------------------------
-- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw 0 & arrowHead .~ noHead)
-- > origin (r2 (0.001, 0))
-- > <> square 0.5 # alignL # lw 0
-- | Utility function to convert any arrowhead to an arrowtail, i.e.
-- attached at the start of the trail.
headToTail :: ArrowHT -> ArrowHT
headToTail hd = tl
where
tl size shaftWidth = (t, j)
where
(t', j') = hd size shaftWidth
t = reflectX t'
j = reflectX j'
arrowtailBlock :: Angle a => a -> ArrowHT
arrowtailBlock theta = aTail
where
aTail size _ = (t, mempty)
where
t = square 1 # scaleX x # scaleY y # scale size # alignR
a' = e theta # scaleR
a = a' ^-^ (reflectY a')
y = magnitude a
b = a' ^-^ (reflectX a')
x = magnitude b
-- | The angle is where the top left corner intersects the circle.
arrowtailQuill :: Angle a => a -> ArrowHT
arrowtailQuill theta =aTail
where
aTail size shaftWidth = (t, j)
where
t = ( closedPath $ trailFromVertices [v0, v1, v2, v3, v4, v5, v0] )
# scale size # alignR
theta' = toTurn theta
v0 = p2 (0.5, 0)
v2 = p2 (unr2 $ e theta' # scaleR)
v1 = v2 # translateX (5/4 * htRadius)
v3 = p2 (-0.1, 0)
v4 = v2 # reflectY
v5 = v4 # translateX (5/4 * htRadius)
s = 1 - shaftWidth / magnitude (v1 .-. v5)
n1 = v0 # translateY (0.5 * shaftWidth)
n2 = v1 .-^ ((v1 .-. v0) # scale s)
n3 = v5 .-^ ((v5 .-. v0) # scale s)
n4 = n1 # reflectY
j = ( closedPath $ trailFromVertices
[ v0, n1, n2, v0, n3, n4, v0 ])
-- Standard tails ---------------------------------------------------------
noTail :: ArrowHT
noTail _ _ = (mempty, mempty)
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg#diagram=tri'Ex&width=100>>
-- > tri'Ex = drawTail tri'
tri' :: ArrowHT
tri' = headToTail tri
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg#diagram=spike'Ex&width=100>>
-- > spike'Ex = drawTail spike'
spike' :: ArrowHT
spike' = headToTail spike
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg#diagram=thorn'Ex&width=100>>
-- > thorn'Ex = drawTail thorn'
thorn' :: ArrowHT
thorn' = headToTail thorn
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg#diagram=dart'Ex&width=100>>
-- > dart'Ex = drawTail dart'
dart' :: ArrowHT
dart' = headToTail dart
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_missile'Ex.svg#diagram=missile'Ex&width=100>>
-- > missile'Ex = drawTail missile'
missile' :: ArrowHT
missile' = headToTail missile
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg#diagram=quillEx&width=100>>
-- > quillEx = drawTail quill
quill :: ArrowHT
quill = arrowtailQuill (2/5 :: Turn)
-- | <<diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg#diagram=blockEx&width=100>>
-- > blockEx = drawTail block
block :: ArrowHT
block = arrowtailBlock (2/5 :: Turn)