module Diagrams.Backend.HsQML.Render where
import Diagrams.Backend.HsQML.DiagramObj
import Data.Foldable (foldl', foldMap)
import Control.Lens hiding ((#), from)
import Data.Monoid
import Data.Tree
import Data.Typeable
import Diagrams.Prelude hiding ((<>), start, moveTo, stroke, text)
import Diagrams.Core.Types
import Diagrams.TwoD.Adjust
import Diagrams.TwoD.Attributes(LineTexture, FillTexture)
import Diagrams.TwoD.Path (getFillRule)
import Diagrams.TwoD.Text hiding (text)
import Graphics.QML
data HsQML = HsQML deriving Typeable
instance Backend HsQML R2 where
data Render HsQML R2 = HsQMLRender {getObj :: DiagramObj ()}
type Result HsQML R2 = IO (ObjRef (DiagramObj ()))
data Options HsQML R2 = HsQMLOptions { _sizeSpec :: SizeSpec2D }
renderRTree HsQML opts tree = newObjectDC . getObj $ renderHsQML opts tree
adjustDia HsQML opts dia = adjustDia2D sizeSpec HsQML opts (dia # reflectY)
sizeSpec
:: Functor f => (SizeSpec2D -> f SizeSpec2D) -> Options HsQML R2 -> f (Options HsQML R2)
sizeSpec = lens (\(HsQMLOptions s) -> s) (\_ s -> HsQMLOptions s)
addAnnotation :: String -> DiagramObj ()
addAnnotation _ = mempty
useStyle :: Style R2 -> DiagramObj ()
useStyle s = maybe mempty id . foldMap ($s) $
[ handle $ setLineCap.getLineCap
, handle $ setLineJoin.getLineJoin
, handle setLineMiterLimit
, handle setOpacity
, handle setLineWidth
, handle setLineTexture
, handle setFillTexture
, handle setFont
, handle $ setFillRule.getFillRule
]
where handle f = fmap f.getAttr
renderHsQML :: Options HsQML R2 -> RTree HsQML R2 Annotation -> Render HsQML R2
renderHsQML opts (Node root ns) =
case root of
RStyle s -> HsQMLRender $ save <> useStyle s <> proceed <> restore
RAnnot (Href s) -> HsQMLRender $ addAnnotation s <> proceed
RPrim p -> render HsQML p
REmpty -> HsQMLRender $ proceed
where
proceed = mconcat $ map (getObj . renderHsQML opts) ns
instance Renderable Text HsQML where
render HsQML (Text _ t2 _ str) = HsQMLRender $ text str x y
where (x,y) = unp2 . papply t2 $ origin
renderTrail :: P2 -> Trail R2 -> DiagramObj ()
renderTrail start trail = mconcat
[ beginPath
, moveTo start
, withTrail (\(Line (SegTree tree) ) -> fst $ renderTree tree)
(\(Loop (SegTree tree) closing) ->
let (d, prev) = renderTree tree
in d <> closeSeg closing prev start <> closePath <> fill)
trail
, stroke
]
where renderTree = foldl' renderNode (mempty, start)
renderNode (d, p) seg = ( d <> renderSeg p seg
, next)
where next = p .+^ segOffset seg
renderSeg :: P2 -> Segment Closed R2 -> DiagramObj ()
renderSeg from (Linear (OffsetClosed v)) = lineTo (from .+^ v)
renderSeg from (Cubic c1 c2 (OffsetClosed v)) = bezierCurveTo (from .+^ c1) (from .+^ c2) (from .+^ v)
closeSeg
:: Segment Open R2
-> P2
-> P2
-> DiagramObj ()
closeSeg (Linear _) _ start = lineTo start
closeSeg (Cubic c1 c2 _) prev start = bezierCurveTo (prev .+^ c1) (prev .+^ c2) start
instance Renderable (Trail R2) HsQML where
render HsQML trail = HsQMLRender $ renderTrail origin trail
instance Renderable (Path R2) HsQML where
render HsQML path = HsQMLRender . foldMap (uncurry renderTrail . viewLoc) $ pathTrails path