module Diagrams.Backend.HsQML.Render where
import Diagrams.Backend.HsQML.DiagramObj
import Data.Foldable (foldl', foldMap)
import Control.Lens hiding ((#), from, transform, under)
import Data.Monoid
import Data.Tree
import Data.Typeable
import Diagrams.Prelude hiding ((<>), start, moveTo, stroke, text, from)
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
type instance V HsQML = V2
type instance N HsQML = Double
instance Backend HsQML V2 Double where
data Render HsQML V2 Double = HsQMLRender {getObj :: DiagramObj ()}
type Result HsQML V2 Double = IO (ObjRef (DiagramObj ()))
data Options HsQML V2 Double = HsQMLOptions { _sizeSpec :: SizeSpec V2 Double }
renderRTree HsQML opts tree = newObjectDC . getObj $ renderHsQML opts tree
adjustDia HsQML opts dia = (opts', reflectionY <> trans, dia' # scale 0.87 `underT` inv trans)
where
(opts', trans, dia') = adjustDia2D sizeSpec HsQML opts $ reflectY dia
sizeSpec
:: Functor f => (SizeSpec V2 Double -> f (SizeSpec V2 Double)) -> Options HsQML V2 Double -> f (Options HsQML V2 Double)
sizeSpec = lens (\(HsQMLOptions s) -> s) (\_ s -> HsQMLOptions s)
addAnnotation :: Annotation -> DiagramObj ()
addAnnotation _ = mempty
useStyle :: Style V2 Double -> 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 V2 Double -> RTree HsQML V2 Double Annotation -> Render HsQML V2 Double
renderHsQML opts (Node root ns) =
case root of
RStyle s -> HsQMLRender $ save <> useStyle s <> proceed <> restore
RAnnot a -> HsQMLRender $ addAnnotation a <> proceed
RPrim p -> render HsQML p
REmpty -> HsQMLRender $ proceed
where
proceed = mconcat $ map (getObj . renderHsQML opts) ns
instance Renderable (Text Double) HsQML where
render HsQML (Text t2 _ str) = HsQMLRender $ text str x y
where (x,y) = unp2 . papply t2 $ origin
renderTrail :: P2 Double -> Trail V2 Double -> 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 Double -> Segment Closed V2 Double -> 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 V2 Double
-> P2 Double
-> P2 Double
-> DiagramObj ()
closeSeg (Linear _) _ start = lineTo start
closeSeg (Cubic c1 c2 _) prev start = bezierCurveTo (prev .+^ c1) (prev .+^ c2) start
instance Renderable (Trail V2 Double) HsQML where
render HsQML trail = HsQMLRender $ renderTrail origin trail
instance Renderable (Path V2 Double) HsQML where
render HsQML path = HsQMLRender . foldMap (uncurry renderTrail . viewLoc) $ pathTrails path