Skip to content

Instantly share code, notes, and snippets.

@sebug sebug/SmartArt.purs
Created Jul 8, 2016

Embed
What would you like to do?
Canvas schematic arrows
module SmartArt where
import Prelude (bind, ($), (+), (*), (-), (/), pure)
import Control.Monad.Eff (Eff)
import Graphics.Canvas (CANVAS, fillPath, setFillStyle, moveTo, lineTo, fillText, setFont, measureText, Context2D)
import Data.List (List(..))
drawArrows :: forall eff. Context2D -> Number -> Number -> Number -> List String -> Eff (canvas :: CANVAS | eff) Number
drawArrows ctx dx x y Nil = pure x
drawArrows ctx dx x y (Cons l ls) = do
drawnWidth <- drawArrow ctx x y l
drawArrows ctx dx (x + drawnWidth + dx) y ls
drawArrow :: forall eff. Context2D -> Number -> Number -> String -> Eff (canvas :: CANVAS | eff) Number
drawArrow ctx x y txt = do
setFillStyle "#FF00AA" ctx
let u = 20.0
rectHeight = 4.0
arrowLength = 3.0
arrowDelta = 1.0
padding = 5.0
setFont "normal 20pt sans-serif" ctx
m <- measureText ctx txt
let rectLength = m.width + 2.0 * padding
fillPath ctx $ do
moveTo ctx x y
lineTo ctx (x + rectLength) y
lineTo ctx (x + rectLength) (y - (arrowDelta * u))
lineTo ctx (x + (rectLength + (arrowLength) * u)) (y + (rectHeight * u / 2.0))
lineTo ctx (x + rectLength) (y + (rectHeight * u + (arrowDelta * u)))
lineTo ctx (x + rectLength) (y + (rectHeight * u))
lineTo ctx x (y + (rectHeight * u))
lineTo ctx x y
setFillStyle "#000000" ctx
fillText ctx txt (x + padding) (y + 10.0 + (rectHeight * u / 2.0))
pure (rectLength + (arrowLength * u))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.