{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Arrows.Tips -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Anchor points on shapes. -- -- \*\* WARNING \*\* this module is an experiment, and may -- change significantly in future revisions. -- -------------------------------------------------------------------------------- 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.Basic.Utils.Combinators import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Control.Applicative -- | Encode an arrowhead as an image where the /answer/ is the -- retract distance. -- -- The retract distance is context sensitive - usually just on -- the markHeight (or halfMarkHeight) so it has to be calculated -- w.r.t. the DrawingCtx. -- newtype Arrowhead u = Arrowhead { getArrowhead :: ThetaLocImage u u } -- | Tiplen is length of the tip \*along the line it follows\*. -- -- > |\ -- > | \ -- > | / -- > |/ -- > -- > | | -- tip len -- -- | Tip width is the distance between upper and lower -- arrow points. -- -- > __ -- > |\ -- > | \ tip -- > | / width -- > |/ __ -- > -- | This one is for triangular tips defined by their tip angle -- e.g. 90deg, 60deg, 45deg. -- -- The tip width will be variable (tip length should be the -- markHeight). -- 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 -- theta in the opposite direction vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len -- | This one is for triangles when the tip height and tip width -- are known. -- 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 -- theta in the opposite direction vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len {- markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u markHeightPlusLineWidth = (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth -} markHeightLessLineWidth :: (Fractional u, FromPtSize u) => DrawingR u markHeightLessLineWidth = (\h lw -> h - realToFrac lw) <$> markHeight <*> lineWidth -- noRetract ignores both the angle and the point. -- -- Its common for the rectraction not to care about the angle or -- the point and only care about the DrawingCtx. -- noRetract :: Num u => ThetaLocDrawingR u u noRetract = rlift2 $ pure 0 -------------------------------------------------------------------------------- -- | Tripoints takes the \*tip length\* is the mark height. -- -- This means that the 90deg tip has a tip width greater-than the -- mark height (but that is okay - seemingly this is how TikZ -- does it). -- tripointsByAngle :: (Floating u, FromPtSize u) => Radian -> ThetaLocDrawingR u (Point2 u, Point2 u) tripointsByAngle triang theta pt = (\h -> let (vupper,vlower) = triVecsByAngle h (0.5*triang) theta in (pt .+^ vupper, pt .+^ vlower)) <$> markHeight revtripointsByAngle :: (Floating u, FromPtSize u) => Radian -> ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u) revtripointsByAngle triang theta pt = (\h -> let theta' = circularModulo $ pi+theta (vupper,vlower) = triVecsByAngle h (0.5*triang) theta' back_tip = pt .-^ avec theta h in (back_tip .+^ vupper, back_tip, back_tip .+^ vlower) ) <$> markHeight tripointsByDist :: (Real u, Floating u, FromPtSize u) => ThetaLocDrawingR u (Point2 u, Point2 u) tripointsByDist theta pt = (\h -> let (vup,vlo) = triVecsByDist h (0.5*h) theta in (pt .+^ vup, pt .+^ vlo)) <$> markHeight revtripointsByDist :: (Real u, Floating u, FromPtSize u) => ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u) revtripointsByDist theta pt = (\h -> 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)) <$> markHeight -- width = xchar_height -- filled with stroke colour! triTLG :: (Floating u, Real u, FromPtSize u) => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u triTLG triang drawF = tripointsByAngle triang `bindR2` \(u,v) -> rlift1 $ \pt -> localize bothStrokeColour $ drawF $ vertexPath [pt,u,v] tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri90 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) filledPath) tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri60 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) filledPath) tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri45 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) filledPath) otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri90 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) closedStroke) otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri60 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) closedStroke) otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri45 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) closedStroke) -- width = xchar_height -- filled with stroke colour! revtriTLG :: (Floating u, Real u, FromPtSize u) => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u revtriTLG triang drawF = revtripointsByAngle triang `bindR2` \(u,pt,v) -> rlift2 $ localize bothStrokeColour $ drawF $ vertexPath [u,pt,v] revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri90 = Arrowhead $ intoThetaLocImage (rlift2 markHeightLessLineWidth) (revtriTLG (pi/2) filledPath) revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri60 = Arrowhead $ intoThetaLocImage (rlift2 markHeightLessLineWidth) (revtriTLG (pi/3) filledPath) revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri45 = Arrowhead $ intoThetaLocImage (rlift2 markHeightLessLineWidth) (revtriTLG (pi/4) filledPath) orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri90 = Arrowhead $ intoThetaLocImage (rlift2 markHeightLessLineWidth) (revtriTLG (pi/2) closedStroke) orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri60 = Arrowhead $ intoThetaLocImage (rlift2 markHeightLessLineWidth) (revtriTLG (pi/3) closedStroke) orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri45 = Arrowhead $ intoThetaLocImage (rlift2 markHeightLessLineWidth) (revtriTLG (pi/4) closedStroke) barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u barbTLG ang = tripointsByAngle ang `bindR2` \(u,v) -> rlift1 $ \pt -> openStroke $ vertexPath [u,pt,v] barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u barb90 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/2)) barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u barb60 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/3)) barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u barb45 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/4)) revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u revbarbTLG ang = revtripointsByAngle ang `bindR2` \(u,pt,v) -> rlift2 $ openStroke $ vertexPath [u,pt,v] revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb90 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/2)) revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb60 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/3)) revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb45 = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/4)) perpTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u perpTLG = bindAskR2 markHalfHeight $ \hh -> \theta pt -> let p0 = displacePerpendicular hh theta pt p1 = displacePerpendicular (-hh) theta pt in straightLineBetween p0 p1 perp :: (Floating u, FromPtSize u) => Arrowhead u perp = Arrowhead $ intoThetaLocImage noRetract perpTLG bracketTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u bracketTLG = bindAskR2 markHalfHeight $ \hh -> \theta pt -> let p1 = displacePerpendicular hh theta pt p0 = displaceParallel (-hh) theta p1 p2 = displacePerpendicular (-hh) theta pt p3 = displaceParallel (-hh) theta p2 in openStroke $ vertexPath [p0,p1,p2,p3] bracket :: (Floating u, FromPtSize u) => Arrowhead u bracket = Arrowhead $ intoThetaLocImage noRetract bracketTLG diskTLG :: (Floating u, FromPtSize u) => (u -> Point2 u -> Graphic u) -> ThetaLocGraphic u diskTLG drawF = bindAskR2 markHalfHeight $ \hh -> \theta pt -> let ctr = pt .-^ avec theta hh in drawF hh ctr diskTip :: (Floating u, FromPtSize u) => Arrowhead u diskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF) where drawF r pt = localize bothStrokeColour $ filledDisk r pt odiskTip :: (Floating u, FromPtSize u) => Arrowhead u odiskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF) where drawF r pt = strokedDisk r pt squareTLG :: (Floating u, FromPtSize u) => (PrimPath u -> Graphic u) -> ThetaLocGraphic u squareTLG drawF = bindAskR2 markHalfHeight $ \hh -> \theta pt -> 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 $ intoThetaLocImage (rlift2 markHeight) (squareTLG drawF) where drawF = localize bothStrokeColour . filledPath osquareTip :: (Floating u, FromPtSize u) => Arrowhead u osquareTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (squareTLG closedStroke) diamondTLG :: (Floating u, FromPtSize u) => (PrimPath u -> Graphic u) -> ThetaLocGraphic u diamondTLG drawF = bindAskR2 markHalfHeight $ \hh -> \theta pt -> 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 $ intoThetaLocImage (rlift2 $ fmap (2*) markHeightLessLineWidth) (diamondTLG drawF) where drawF = localize bothStrokeColour . filledPath odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u odiamondTip = Arrowhead $ intoThetaLocImage (rlift2 $ fmap (2*) markHeight) (diamondTLG closedStroke) -- Note - points flipped to get the second trapezium to -- draw /underneath/. -- curveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u curveTLG theta pt = markHalfHeight >>= \hh -> tripointsByDist theta pt >>= \(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 $ intoThetaLocImage (rlift2 $ fmap realToFrac lineWidth) curveTLG -- Note - points flipped to get the second trapezium to -- draw /underneath/. -- revcurveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u revcurveTLG theta pt = markHalfHeight >>= \hh -> revtripointsByDist theta pt >>= \(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 $ intoThetaLocImage (rlift2 markHeight) revcurveTLG