module Wumpus.Basic.Arrows.Tips
(
Arrowhead(..)
, tri90
, tri60
, tri45
, otri90
, otri60
, otri45
, revtri90
, revtri60
, revtri45
, orevtri90
, orevtri60
, orevtri45
, barb90
, barb60
, barb45
, revbarb90
, revbarb60
, revbarb45
, perp
, bracket
, diskTip
, odiskTip
, squareTip
, osquareTip
, diamondTip
, odiamondTip
, curveTip
, revcurveTip
) where
import Wumpus.Basic.Graphic
import Wumpus.Basic.Paths
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
newtype Arrowhead u = Arrowhead { getArrowhead :: LocThetaImage u u }
triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u)
triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower)
where
hypo_len = tiplen / (fromRadian $ cos halfang)
rtheta = pi + theta
vec_to_upper = avec (circularModulo $ rtheta halfang) hypo_len
vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len
triVecsByDist :: (Real u, Floating u)
=> u -> u -> Radian -> (Vec2 u, Vec2 u)
triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower)
where
hypo_len = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth)
halfang = toRadian $ atan (half_tipwidth / tiplen)
rtheta = pi + theta
vec_to_upper = avec (circularModulo $ rtheta halfang) hypo_len
vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len
markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u
markHeightLessLineWidth =
(\h lw -> h realToFrac lw) <$> markHeight <*> lineWidth
noRetract :: Num u => LocThetaCF u u
noRetract = wrap2 0
tripointsByAngle :: (Floating u, FromPtSize u)
=> Radian -> LocThetaCF u (Point2 u, Point2 u)
tripointsByAngle triang = markHeight >>= \h ->
raise2 $ \pt theta -> let (vup,vlo) = triVecsByAngle h (0.5*triang) theta
in (pt .+^ vup, pt .+^ vlo)
revtripointsByAngle :: (Floating u, FromPtSize u)
=> Radian
-> LocThetaCF u (Point2 u, Point2 u, Point2 u)
revtripointsByAngle triang = markHeight >>= \h ->
raise2 $ \pt theta -> let theta' = circularModulo $ pi+theta
(vup,vlo) = triVecsByAngle h (0.5*triang) theta'
back_tip = pt .-^ avec theta h
in (back_tip .+^ vup, back_tip, back_tip .+^ vlo)
tripointsByDist :: (Real u, Floating u, FromPtSize u)
=> LocThetaCF u (Point2 u, Point2 u)
tripointsByDist = markHeight >>= \h ->
raise2 $ \pt theta -> let (vup,vlo) = triVecsByDist h (0.5*h) theta
in (pt .+^ vup, pt .+^ vlo)
revtripointsByDist :: (Real u, Floating u, FromPtSize u)
=> LocThetaCF u (Point2 u, Point2 u, Point2 u)
revtripointsByDist = markHeight >>= \h ->
raise2 $ \pt theta -> let theta' = circularModulo $ pi+theta
(vup,vlo) = triVecsByDist h (0.5*h) theta'
back_tip = pt .-^ avec theta h
in (back_tip .+^ vup, back_tip, back_tip .+^ vlo)
bindLocTip :: LocThetaCF u a -> (a -> LocGraphic u) -> LocThetaGraphic u
bindLocTip df da = bind2 df (\a -> static2 $ da a)
bindLocThetaTip :: LocThetaCF u a -> (a -> LocThetaGraphic u)
-> LocThetaGraphic u
bindLocThetaTip = bind2
triTLG :: (Floating u, Real u, FromPtSize u)
=> Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u
triTLG triang drawF = localize bothStrokeColour $
bindLocTip (tripointsByAngle triang)
(\(u,v) -> promote1 $ \pt -> drawF $ vertexPath [pt,u,v])
tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
tri90 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) filledPath)
tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
tri60 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) filledPath)
tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
tri45 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) filledPath)
otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
otri90 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) closedStroke)
otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
otri60 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) closedStroke)
otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
otri45 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) closedStroke)
revtriTLG :: (Floating u, Real u, FromPtSize u)
=> Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u
revtriTLG triang drawF = localize bothStrokeColour $
bindLocTip (revtripointsByAngle triang)
(\(u,pt,v) -> static1 $ drawF $ vertexPath [u,pt,v])
revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
revtri90 = Arrowhead $
intoLocThetaImage (dblstatic markHeightLessLineWidth)
(revtriTLG (pi/2) filledPath)
revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
revtri60 = Arrowhead $
intoLocThetaImage (dblstatic markHeightLessLineWidth)
(revtriTLG (pi/3) filledPath)
revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
revtri45 = Arrowhead $
intoLocThetaImage (dblstatic markHeightLessLineWidth)
(revtriTLG (pi/4) filledPath)
orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
orevtri90 = Arrowhead $
intoLocThetaImage (dblstatic markHeightLessLineWidth)
(revtriTLG (pi/2) closedStroke)
orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
orevtri60 = Arrowhead $
intoLocThetaImage (dblstatic markHeightLessLineWidth)
(revtriTLG (pi/3) closedStroke)
orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
orevtri45 = Arrowhead $
intoLocThetaImage (dblstatic markHeightLessLineWidth)
(revtriTLG (pi/4) closedStroke)
barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u
barbTLG ang =
bindLocTip (tripointsByAngle ang)
(\(u,v) -> promote1 $ \pt -> openStroke $ vertexPath [u,pt,v])
barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
barb90 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/2))
barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
barb60 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/3))
barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
barb45 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/4))
revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u
revbarbTLG ang =
bindLocTip (revtripointsByAngle ang)
(\(u,pt,v) -> static1 $ openStroke $ vertexPath [u,pt,v])
revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
revbarb90 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/2))
revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
revbarb60 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/3))
revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u
revbarb45 = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/4))
perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u
perpTLG = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta -> openStroke $ perpPath hh pt theta
perpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u
perpPath hh ctr theta = primPath p0 [lineTo p1]
where
p0 = displacePerpendicular hh theta ctr
p1 = displacePerpendicular (hh) theta ctr
perp :: (Floating u, FromPtSize u) => Arrowhead u
perp = Arrowhead $ intoLocThetaImage noRetract perpTLG
bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u
bracketTLG = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta -> openStroke $ bracketPath hh pt theta
bracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u
bracketPath hh pt theta = vertexPath [p0,p1,p2,p3]
where
p1 = displacePerpendicular hh theta pt
p0 = displaceParallel (hh) theta p1
p2 = displacePerpendicular (hh) theta pt
p3 = displaceParallel (hh) theta p2
bracket :: (Floating u, FromPtSize u) => Arrowhead u
bracket = Arrowhead $ intoLocThetaImage noRetract bracketTLG
diskTLG :: (Floating u, FromPtSize u)
=> (u -> Point2 u -> Graphic u) -> LocThetaGraphic u
diskTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta -> let ctr = pt .-^ avec theta hh
in drawF hh ctr
diskTip :: (Floating u, FromPtSize u) => Arrowhead u
diskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF)
where
drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt
odiskTip :: (Floating u, FromPtSize u) => Arrowhead u
odiskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF)
where
drawF r pt = strokedDisk r `at` pt
squareTLG :: (Floating u, FromPtSize u)
=> (PrimPath u -> Graphic u) -> LocThetaGraphic u
squareTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta ->
let p0 = displacePerpendicular hh theta pt
p3 = displacePerpendicular (hh) theta pt
p1 = displaceParallel (2*hh) theta p0
p2 = displaceParallel (2*hh) theta p3
in drawF $ vertexPath [p0,p1,p2,p3]
squareTip :: (Floating u, FromPtSize u) => Arrowhead u
squareTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (squareTLG drawF)
where
drawF = localize bothStrokeColour . filledPath
osquareTip :: (Floating u, FromPtSize u) => Arrowhead u
osquareTip = Arrowhead $
intoLocThetaImage (dblstatic markHeight) (squareTLG closedStroke)
diamondTLG :: (Floating u, FromPtSize u)
=> (PrimPath u -> Graphic u) -> LocThetaGraphic u
diamondTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta ->
let ctr = displaceParallel (2*hh) theta pt
p1 = displacePerpendicular hh theta ctr
p3 = displacePerpendicular (hh) theta ctr
p2 = displaceParallel (4*hh) theta pt
in drawF $ vertexPath [pt,p1,p2,p3]
diamondTip :: (Floating u, FromPtSize u) => Arrowhead u
diamondTip = Arrowhead $
intoLocThetaImage (dblstatic $ fmap (2*) markHeightLessLineWidth)
(diamondTLG drawF)
where
drawF = localize bothStrokeColour . filledPath
odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u
odiamondTip = Arrowhead $
intoLocThetaImage (dblstatic $ fmap (2*) markHeight) (diamondTLG closedStroke)
curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u
curveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta ->
unLocTheta pt theta tripointsByDist >>= \(tup,tlo) ->
let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup
(l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt
tpath = curve tup u2 u1 pt `append` curve pt l1 l2 tlo
in localize (joinRound . capRound)
(openStroke $ toPrimPath $ tpath)
curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u
curveTip = Arrowhead $
intoLocThetaImage (dblstatic $ fmap realToFrac lineWidth) curveTLG
revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u
revcurveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn
where
fn hh = promote2 $ \pt theta ->
unLocTheta pt theta revtripointsByDist >>= \(tup,p1,tlo) ->
let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup
(l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1
tpath = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo
in localize (joinRound . capRound)
(openStroke $ toPrimPath $ tpath)
revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u
revcurveTip = Arrowhead $
intoLocThetaImage (dblstatic markHeight) revcurveTLG