diagrams-canvas-0.3: src/Diagrams/Backend/Canvas.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-------------------------------------------------------------------------------
-- |
-- Module : Diagrams.Backend.Canvas
-- Copyright : (c) 2010 - 2014 diagrams-canvas team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- A full-featured rendering backend for diagrams using Canvas.
-- Implemented using the blank-canvas platform.
--
-- To invoke the Canvas backend, you have three options.
--
-- * You can use the "Diagrams.Backend.Canvas.CmdLine" module to create
-- standalone executables which will display the diagram in a browser
-- using a web service.
--
-- * You can use the 'renderCanvas' function provided by this module,
-- which gives you more programmatic control over when and
-- how images are displayed (making it east to, for example, write a
-- single program that displays multiple images, or one that diaplays
-- images dynamically based on user input, and so on).
--
-- * For the most flexiblity you can invoke the 'renderDia' method from
-- 'Diagrams.Core.Types.Backend' instance for @Canvas@. In particular,
-- 'Diagrams.Core.Types.renderDia' has the generic type
--
-- > renderDia :: b -> Options b v -> QDiagram b v m -> Result b v
--
-- (omitting a few type class contraints). @b@ represents the
-- backend type, @v@ the vector space, and @m@ the type of monoidal
-- query annotations on the diagram. 'Options' and 'Result' are
-- associated data and type families, respectively, which yield the
-- type of option records and rendering results specific to any
-- particular backend. For @b ~ Canvas@ and @v ~ R2@, we have
--
-- > data Options Canvas R2 = CanvaseOptions
-- > { _size :: SizeSpec2D -- ^^ The requested size
-- > }
--
-- @
-- data family Render Canvas R2 = C (RenderM ())
-- @
--
-- @
-- type family Result Canvas R2 = Canvas ()
-- @
--
-- So the type of 'renderDia' resolves to
--
-- @
-- renderDia :: Canvas -> Options Canvas R2 -> QDiagram Canvas R2 m ->
-- Canvas()
-- @
--
-- which you could call like @renderDia Canvas (CanvaseOptions (width 250))
-- myDiagram@
--
------------------------------------------------------------------------------
module Diagrams.Backend.Canvas
( Canvas(..) -- rendering token
, B
, Options(..) -- for rendering options specific to Canvas
, renderCanvas
) where
import Control.Arrow ((***))
import Control.Lens hiding (transform, (#))
import Control.Monad.State (when, State, evalState)
import qualified Control.Monad.StateStack as SS
import Control.Monad.Trans (lift)
import Data.Default.Class
import qualified Data.Foldable as F
import Data.Maybe (catMaybes, isJust, fromJust, fromMaybe)
import Data.NumInstances ()
import qualified Data.Text as T
import Data.Tree (Tree(Node))
import Data.Typeable (Typeable)
import Data.Word (Word8)
import Diagrams.Attributes
import Diagrams.Prelude hiding (fillTexture, moveTo, stroke)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Attributes (splitTextureFills)
import Diagrams.TwoD.Path (Clip (Clip))
import Diagrams.TwoD.Text
import Diagrams.TwoD.Types (R2(..))
import Diagrams.Core.Compile
import Diagrams.Core.Transform (matrixHomRep)
import Diagrams.Core.Types (Annotation (..))
import qualified Graphics.Blank as BC
import qualified Graphics.Blank.Style as S
-- | This data declaration is simply used as a token to distinguish
-- this rendering engine.
data Canvas = Canvas
deriving (Eq, Ord, Read, Show, Typeable)
type B = Canvas
data CanvasState = CanvasState { _accumStyle :: Style R2
, _csPos :: (Double, Double) }
makeLenses ''CanvasState
instance Default CanvasState where
def = CanvasState { _accumStyle = mempty
, _csPos = (0,0) }
type RenderM a = SS.StateStackT CanvasState BC.Canvas a
liftC :: BC.Canvas a -> RenderM a
liftC = lift
runRenderM :: RenderM a -> BC.Canvas a
runRenderM = flip SS.evalStateStackT def
instance Monoid (Render Canvas R2) where
mempty = C $ return ()
(C c1) `mappend` (C c2) = C (c1 >> c2)
instance Backend Canvas R2 where
data Render Canvas R2 = C (RenderM ())
type Result Canvas R2 = BC.Canvas ()
data Options Canvas R2 = CanvasOptions
{ _canvasSize :: SizeSpec2D -- ^ the requested size
}
renderRTree :: Canvas -> Options Canvas R2 -> RTree Canvas R2 Annotation
-> Result Canvas R2
renderRTree _ _ rt = evalState canvasOutput initialCanvasRenderState
where
canvasOutput :: State CanvasRenderState (BC.Canvas ())
canvasOutput = do
let C r = toRender rt
return $ runRenderM $ r
adjustDia c opts d = adjustDia2D size c opts (d # reflectY)
runC :: Render Canvas R2 -> RenderM ()
runC (C r) = r
toRender :: RTree Canvas R2 Annotation -> Render Canvas R2
toRender = fromRTree
. Node (RStyle (mempty # recommendFillColor (transparent :: AlphaColour Double)))
. (:[])
. splitTextureFills
where
fromRTree (Node (RPrim p) _) = render Canvas p
fromRTree (Node (RStyle sty) rs) = C $ do
save
canvasStyle sty
accumStyle %= (<> sty)
runC $ F.foldMap fromRTree rs
restore
fromRTree (Node _ rs) = F.foldMap fromRTree rs
data CanvasRenderState = CanvasRenderState
initialCanvasRenderState :: CanvasRenderState
initialCanvasRenderState = CanvasRenderState
getSize :: Options Canvas R2 -> SizeSpec2D
getSize (CanvasOptions {_canvasSize = s}) = s
setSize :: Options Canvas R2 -> SizeSpec2D -> Options Canvas R2
setSize o s = o {_canvasSize = s}
size :: Lens' (Options Canvas R2) SizeSpec2D
size = lens getSize setSize
move :: (Double, Double) -> RenderM ()
move p = do csPos .= p
save :: RenderM ()
save = SS.save >> liftC (BC.save ())
restore :: RenderM ()
restore = liftC (BC.restore ()) >> SS.restore
newPath :: RenderM ()
newPath = liftC $ BC.beginPath ()
closePath :: RenderM ()
closePath = liftC $ BC.closePath ()
moveTo :: Double -> Double -> RenderM ()
moveTo x y = do
let x' = realToFrac x
y' = realToFrac y
liftC $ BC.moveTo (x', y')
move (x', y')
relLineTo :: Double -> Double -> RenderM ()
relLineTo x y = do
p <- use csPos
let p' = p + (realToFrac x, realToFrac y)
liftC $ BC.lineTo p'
move p'
relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo ax ay bx by cx cy = do
p <- use csPos
let [(ax',ay'),(bx',by'),(cx',cy')] = map ((p +) . (realToFrac *** realToFrac))
[(ax,ay),(bx,by),(cx,cy)]
liftC $ BC.bezierCurveTo (ax',ay',bx',by',cx',cy')
move (cx', cy')
-- | Get an accumulated style attribute from the render monad state.
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib f = (fmap f . getAttr) <$> use accumStyle
-- | From the HTML5 canvas specification regarding line width:
--
-- "On setting, zero, negative, infinite, and NaN values must be
-- ignored, leaving the value unchanged; other values must change
-- the current value to the new value.
--
-- Hence we must implement a line width of zero by simply not
-- sending a stroke command.
stroke :: RenderM ()
stroke = do
-- The default value of 0.5 is somewhat arbitary since lineWidth should neve
-- be 'Nothing'. 0.5 is choose since it is the lower bound of the
-- default.
w <- fromMaybe 0.5 <$> getStyleAttrib (fromOutput . getLineWidth)
when (w > 0) (liftC $ BC.stroke ())
fill :: RenderM ()
fill = liftC $ BC.fill ()
clip :: RenderM ()
clip = liftC $ BC.clip ()
byteRange :: Double -> Word8
byteRange d = floor (d * 255)
data TextureUse = Fill | Strk
texture :: TextureUse -> Texture -> Double -> RenderM()
texture u (SC (SomeColor c)) o = case u of
Fill -> liftC . S.fillStyle $ s
Strk -> liftC . S.strokeStyle $ s
where s = showColorJS c o
texture u (LG g) _ = liftC $ do
grd <- BC.createLinearGradient (x0, y0, x1, y1)
mapM_ (flip BC.addColorStop $ grd) stops
case u of
Fill -> S.fillStyle grd
Strk -> S.strokeStyle grd
where
(x0', y0') = unp2 $ transform (g^.lGradTrans) (g^.lGradStart)
(x1', y1') = unp2 $ transform (g^.lGradTrans) (g^.lGradEnd)
(x0, y0, x1, y1) = ( realToFrac x0', realToFrac y0'
, realToFrac x1', realToFrac y1')
stops = map (\s -> ( realToFrac (s^.stopFraction)
, showColorJS (s^.stopColor) 1)) (g^.lGradStops)
texture u (RG g) _ = liftC $ do
grd <- BC.createRadialGradient (x0, y0, r0, x1, y1, r1)
mapM_ (flip BC.addColorStop $ grd) stops
case u of
Fill -> S.fillStyle grd
Strk -> S.strokeStyle grd
where
(r0, r1) = (s * realToFrac (g^.rGradRadius0), s * realToFrac (g^.rGradRadius1))
(x0', y0') = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter0)
(x1', y1') = unp2 $ transform (g^.rGradTrans) (g^.rGradCenter1)
(x0, y0, x1, y1) = ( realToFrac x0', realToFrac y0'
, realToFrac x1', realToFrac y1')
stops = map (\st -> ( realToFrac (st^.stopFraction)
, showColorJS (st^.stopColor) 1)) (g^.rGradStops)
s = realToFrac . avgScale $ (g^.rGradTrans)
showColorJS :: (Color c) => c -> Double -> T.Text
showColorJS c o = T.concat
[ "rgba("
, s r, ","
, s g, ","
, s b, ","
, T.pack (show $ a * o)
, ")"
]
where s :: Double -> T.Text
s = T.pack . show . byteRange
(r,g,b,a) = colorToSRGBA . toAlphaColour $ c
canvasTransform :: T2 -> RenderM ()
canvasTransform tr = liftC $ BC.transform vs
where
[[ax, ay], [bx, by], [tx, ty]] = matrixHomRep tr
vs = (realToFrac ax,realToFrac ay
,realToFrac bx,realToFrac by
,realToFrac tx,realToFrac ty)
strokeTexture :: Texture -> Double -> RenderM ()
strokeTexture = texture Strk
fillTexture :: Texture -> Double -> RenderM ()
fillTexture = texture Fill
fromLineCap :: LineCap -> BC.LineEndCap
fromLineCap LineCapRound = BC.RoundCap
fromLineCap LineCapSquare = BC.SquareCap
fromLineCap _ = BC.ButtCap
fromLineJoin :: LineJoin -> BC.LineJoinCorner
fromLineJoin LineJoinRound = BC.RoundCorner
fromLineJoin LineJoinBevel = BC.BevelCorner
fromLineJoin _ = BC.MiterCorner
showFontJS :: FontWeight -> FontSlant -> Double -> String -> T.Text
showFontJS wgt slant sz fnt = T.concat [a, " ", b, " ", c, " ", d]
where
a = case wgt of
FontWeightNormal -> ""
FontWeightBold -> "bold"
b = case slant of
FontSlantNormal -> ""
FontSlantItalic -> "italic"
FontSlantOblique -> "oblique"
c = T.concat [T.pack $ show sz, "pt"]
d = T.pack fnt
renderC :: (Renderable a Canvas, V a ~ R2) => a -> RenderM ()
renderC a = case (render Canvas a) of C r -> r
canvasStyle :: Style v -> RenderM ()
canvasStyle s = sequence_
. catMaybes $ [ handle clip'
, handle lWidth
, handle lCap
, handle lJoin
]
where handle :: (AttributeClass a) => (a -> RenderM ()) -> Maybe (RenderM ())
handle f = f `fmap` getAttr s
clip' = mapM_ (\p -> canvasPath p >> clip) . op Clip
lWidth = liftC . BC.lineWidth . realToFrac . fromOutput . getLineWidth
lCap = liftC . BC.lineCap . fromLineCap . getLineCap
lJoin = liftC . BC.lineJoin . fromLineJoin . getLineJoin
instance Renderable (Segment Closed R2) Canvas where
render _ (Linear (OffsetClosed (R2 x y))) = C $ relLineTo x y
render _ (Cubic (R2 x1 y1)
(R2 x2 y2)
(OffsetClosed (R2 x3 y3)))
= C $ relCurveTo x1 y1 x2 y2 x3 y3
instance Renderable (Trail R2) Canvas where
render _ = withTrail renderLine renderLoop
where
renderLine ln = C $ do
mapM_ renderC (lineSegments ln)
renderLoop lp = C $ do
case loopSegments lp of
(segs, Linear _) -> mapM_ renderC segs
_ -> mapM_ renderC (lineSegments . cutLoop $ lp)
closePath
instance Renderable (Path R2) Canvas where
render _ p = C $ do
canvasPath p
f <- getStyleAttrib getFillTexture
s <- getStyleAttrib getLineTexture
o <- fromMaybe 1 <$> getStyleAttrib getOpacity
save
when (isJust f) (fillTexture (fromJust f) o >> fill)
strokeTexture (fromMaybe (SC (SomeColor (black :: Colour Double))) s) o
stroke
restore
-- Add a path to the Canvas context, without stroking or filling it.
canvasPath :: Path R2 -> RenderM ()
canvasPath (Path trs) = do
newPath
F.mapM_ renderTrail trs
where
renderTrail (viewLoc -> (unp2 -> p, tr)) = do
uncurry moveTo p
renderC tr
instance Renderable Text Canvas where
render _ (Text tt tn al str) = C $ do
isLocal <- fromMaybe True <$> getStyleAttrib getFontSizeIsLocal
tf <- fromMaybe "Calibri" <$> getStyleAttrib getFont
sz <- fromMaybe 12 <$> getStyleAttrib (fromOutput . getFontSize)
slant <- fromMaybe FontSlantNormal <$> getStyleAttrib getFontSlant
fw <- fromMaybe FontWeightNormal <$> getStyleAttrib getFontWeight
tx <- fromMaybe (SC (SomeColor (black :: Colour Double)))
<$> getStyleAttrib getFillTexture
o <- fromMaybe 1 <$> getStyleAttrib getOpacity
let fSize = if isLocal
then avgScale tt * sz
else sz
fnt = showFontJS fw slant fSize tf
vAlign = case al of
BaselineText -> BC.AlphabeticBaseline
BoxAlignedText _ h -> case h of
h' | h' <= 0.25 -> BC.BottomBaseline
h' | h' >= 0.75 -> BC.TopBaseline
_ -> BC.MiddleBaseline
hAlign = case al of
BaselineText -> BC.StartAnchor
BoxAlignedText w _ -> case w of
w' | w' <= 0.25 -> BC.StartAnchor
w' | w' >= 0.75 -> BC.EndAnchor
_ -> BC.CenterAnchor
save
liftC $ BC.textBaseline vAlign
liftC $ BC.textAlign hAlign
liftC $ BC.font fnt
fillTexture tx o
canvasTransform (tn <> reflectionY)
liftC $ BC.fillText (T.pack str, 0, 0)
restore
instance Renderable (DImage External) Canvas where
render _ (DImage path w h tr) = C $ do
let ImageRef file = path
save
canvasTransform (tr <> reflectionY)
img <- liftC $ BC.newImage (T.pack file)
liftC $ BC.drawImage (img, [fromIntegral (-w) / 2, fromIntegral (-h) / 2, fromIntegral w, fromIntegral h])
restore
renderCanvas :: Int -> SizeSpec2D -> Diagram Canvas R2 -> IO ()
renderCanvas port sizeSpec d = BC.blankCanvas (fromIntegral port) . flip BC.send $ img
where
img = renderDia Canvas (CanvasOptions sizeSpec) d