module Wumpus.Basic.Arrows
(
line
, arrowTri90
, arrowTri60
, arrowTri45
, arrowOTri90
, arrowOTri60
, arrowOTri45
, arrowBarb90
, arrowBarb60
, arrowBarb45
, arrowPerp
) where
import Wumpus.Basic.Arrows.Tips
import Wumpus.Basic.Graphic
import Wumpus.Basic.Paths
import Wumpus.Basic.Paths.Base
import Wumpus.Basic.Utils.Intersection ( langle )
import Wumpus.Core
import Control.Applicative
liftPathF :: PathF u -> ConnDrawingObject u (Path u)
liftPathF pF p1 p2 = DrawingObject $ \ _ -> pF p1 p2
line :: Num u => PathF u -> ConnImage u (Path u)
line pathF = intoConnImage (liftPathF pathF) (pathGraphic pathF)
lineTipR :: Num u => Path u -> Graphic u -> Graphic u
lineTipR bpath tip = openStroke (toPrimPathU bpath) `appendGraphic` tip
rightPathProps :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnDrawingObject u (Path u,Radian)
rightPathProps pathF p1 p2 =
(\h sw -> (shortenPath h sw, calcTheta h))
<$> asksObj lowerxHeight <*> asksObj (line_width . stroke_props)
where
long_path = pathF p1 p2
shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path
calcTheta lxh = directionR $ shortenR (0.5*lxh) long_path
triTipRight :: (Real u, Floating u, FromPtSize u)
=> PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)
triTipRight pathF tipF p1 p2 =
rightPathProps pathF p1 p2 >>= \(shortF,theta) ->
lineTipR shortF (tipF theta p2) >>= \arrow_pic ->
return (pathF p1 p2, arrow_pic)
barbTipRight :: (Real u, Floating u, FromPtSize u)
=> PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u)
barbTipRight pathF tipF p1 p2 =
rightPathProps pathF p1 p2 >>= \(_,theta) ->
lineTipR path_zero (tipF theta p2) >>= \arrow_pic ->
return (path_zero, arrow_pic)
where
path_zero = pathF p1 p2
arrowTri90 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowTri90 pathF = triTipRight pathF tri90
arrowTri60 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowTri60 pathF = triTipRight pathF tri60
arrowTri45 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowTri45 pathF = triTipRight pathF tri45
arrowOTri90 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowOTri90 pathF = triTipRight pathF otri90
arrowOTri60 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowOTri60 pathF = triTipRight pathF otri60
arrowOTri45 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowOTri45 pathF = triTipRight pathF otri45
arrowBarb90 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowBarb90 pathF = barbTipRight pathF barb90
arrowBarb60 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowBarb60 pathF = barbTipRight pathF barb60
arrowBarb45 :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowBarb45 pathF = barbTipRight pathF barb45
arrowPerp :: (Real u, Floating u, FromPtSize u)
=> PathF u -> ConnImage u (Path u)
arrowPerp pathF p1 p2 =
lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic)
where
path_zero = pathF p1 p2
theta = langle p1 p2
perp_tip = perp theta p2