{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Diagrams.Backend.Canvas
( Canvas(..)
, B
, Options(..)
, renderCanvas
) where
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, size)
import Diagrams.TwoD.Adjust (adjustDia2D)
import Diagrams.TwoD.Attributes (splitTextureFills)
import Diagrams.TwoD.Path (Clip (Clip))
import Diagrams.TwoD.Text
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
data Canvas = Canvas
deriving (Canvas -> Canvas -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Canvas -> Canvas -> Bool
$c/= :: Canvas -> Canvas -> Bool
== :: Canvas -> Canvas -> Bool
$c== :: Canvas -> Canvas -> Bool
Eq, Eq Canvas
Canvas -> Canvas -> Bool
Canvas -> Canvas -> Ordering
Canvas -> Canvas -> Canvas
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Canvas -> Canvas -> Canvas
$cmin :: Canvas -> Canvas -> Canvas
max :: Canvas -> Canvas -> Canvas
$cmax :: Canvas -> Canvas -> Canvas
>= :: Canvas -> Canvas -> Bool
$c>= :: Canvas -> Canvas -> Bool
> :: Canvas -> Canvas -> Bool
$c> :: Canvas -> Canvas -> Bool
<= :: Canvas -> Canvas -> Bool
$c<= :: Canvas -> Canvas -> Bool
< :: Canvas -> Canvas -> Bool
$c< :: Canvas -> Canvas -> Bool
compare :: Canvas -> Canvas -> Ordering
$ccompare :: Canvas -> Canvas -> Ordering
Ord, ReadPrec [Canvas]
ReadPrec Canvas
Int -> ReadS Canvas
ReadS [Canvas]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Canvas]
$creadListPrec :: ReadPrec [Canvas]
readPrec :: ReadPrec Canvas
$creadPrec :: ReadPrec Canvas
readList :: ReadS [Canvas]
$creadList :: ReadS [Canvas]
readsPrec :: Int -> ReadS Canvas
$creadsPrec :: Int -> ReadS Canvas
Read, Int -> Canvas -> ShowS
[Canvas] -> ShowS
Canvas -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Canvas] -> ShowS
$cshowList :: [Canvas] -> ShowS
show :: Canvas -> String
$cshow :: Canvas -> String
showsPrec :: Int -> Canvas -> ShowS
$cshowsPrec :: Int -> Canvas -> ShowS
Show, Typeable)
type B = Canvas
type instance V Canvas = V2
type instance N Canvas = Double
data CanvasState = CanvasState { CanvasState -> Style V2 Double
_accumStyle :: Style V2 Double
, CanvasState -> (Double, Double)
_csPos :: (Double, Double) }
makeLenses ''CanvasState
instance Default CanvasState where
def :: CanvasState
def = CanvasState { _accumStyle :: Style V2 Double
_accumStyle = forall a. Monoid a => a
mempty
, _csPos :: (Double, Double)
_csPos = (Double
0,Double
0) }
type RenderM a = SS.StateStackT CanvasState BC.Canvas a
liftC :: BC.Canvas a -> RenderM a
liftC :: forall a. Canvas a -> RenderM a
liftC = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
runRenderM :: RenderM a -> BC.Canvas a
runRenderM :: forall a. RenderM a -> Canvas a
runRenderM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateStackT s m a -> s -> m a
SS.evalStateStackT forall a. Default a => a
def
instance Semigroup (Render Canvas V2 Double) where
C RenderM ()
c1 <> :: Render Canvas V2 Double
-> Render Canvas V2 Double -> Render Canvas V2 Double
<> C RenderM ()
c2 = RenderM () -> Render Canvas V2 Double
C (RenderM ()
c1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
c2)
instance Monoid (Render Canvas V2 Double) where
mempty :: Render Canvas V2 Double
mempty = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if !MIN_VERSION_base(4,11,0)
mappend = (<>)
#endif
instance Backend Canvas V2 Double where
data Render Canvas V2 Double = C (RenderM ())
type Result Canvas V2 Double = BC.Canvas ()
data Options Canvas V2 Double = CanvasOptions
{ Options Canvas V2 Double -> SizeSpec V2 Double
_canvasSize :: SizeSpec V2 Double
}
renderRTree :: Canvas -> Options Canvas V2 Double -> RTree Canvas V2 Double Annotation
-> Result Canvas V2 Double
renderRTree :: Canvas
-> Options Canvas V2 Double
-> RTree Canvas V2 Double Annotation
-> Result Canvas V2 Double
renderRTree Canvas
_ Options Canvas V2 Double
_ RTree Canvas V2 Double Annotation
rt = forall s a. State s a -> s -> a
evalState State CanvasRenderState (Canvas ())
canvasOutput CanvasRenderState
initialCanvasRenderState
where
canvasOutput :: State CanvasRenderState (BC.Canvas ())
canvasOutput :: State CanvasRenderState (Canvas ())
canvasOutput = do
let C RenderM ()
r = RTree Canvas V2 Double Annotation -> Render Canvas V2 Double
toRender RTree Canvas V2 Double Annotation
rt
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. RenderM a -> Canvas a
runRenderM forall a b. (a -> b) -> a -> b
$ RenderM ()
r
adjustDia :: forall m.
(Additive V2, Monoid' m, Num Double) =>
Canvas
-> Options Canvas V2 Double
-> QDiagram Canvas V2 Double m
-> (Options Canvas V2 Double, Transformation V2 Double,
QDiagram Canvas V2 Double m)
adjustDia Canvas
c Options Canvas V2 Double
opts QDiagram Canvas V2 Double m
d = forall n m b.
(TypeableFloat n, Monoid' m) =>
Lens' (Options b V2 n) (SizeSpec V2 n)
-> b
-> Options b V2 n
-> QDiagram b V2 n m
-> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m)
adjustDia2D Lens' (Options Canvas V2 Double) (SizeSpec V2 Double)
size Canvas
c Options Canvas V2 Double
opts (QDiagram Canvas V2 Double m
d forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY)
runC :: Render Canvas V2 Double -> RenderM ()
runC :: Render Canvas V2 Double -> RenderM ()
runC (C RenderM ()
r) = RenderM ()
r
toRender :: RTree Canvas V2 Double Annotation -> Render Canvas V2 Double
toRender :: RTree Canvas V2 Double Annotation -> Render Canvas V2 Double
toRender = forall {b} {a}.
Renderable (Prim b V2 Double) Canvas =>
Tree (RNode b V2 Double a) -> Render Canvas V2 Double
fromRTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [Tree a] -> Tree a
Node (forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle (forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
# forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor (forall a. Num a => AlphaColour a
transparent :: AlphaColour Double)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (v :: * -> *) n a.
Typeable n =>
RTree b v n a -> RTree b v n a
splitTextureFills
where
fromRTree :: Tree (RNode b V2 Double a) -> Render Canvas V2 Double
fromRTree (Node (RPrim Prim b V2 Double
p) [Tree (RNode b V2 Double a)]
_) = forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Canvas
Canvas Prim b V2 Double
p
fromRTree (Node (RStyle Style V2 Double
sty) [Tree (RNode b V2 Double a)]
rs) = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ do
RenderM ()
save
forall (v :: * -> *). Style v Double -> RenderM ()
canvasStyle Style V2 Double
sty
Lens' CanvasState (Style V2 Double)
accumStyle forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Semigroup a => a -> a -> a
<> Style V2 Double
sty)
Render Canvas V2 Double -> RenderM ()
runC forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (RNode b V2 Double a) -> Render Canvas V2 Double
fromRTree [Tree (RNode b V2 Double a)]
rs
RenderM ()
restore
fromRTree (Node RNode b V2 Double a
_ [Tree (RNode b V2 Double a)]
rs) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Tree (RNode b V2 Double a) -> Render Canvas V2 Double
fromRTree [Tree (RNode b V2 Double a)]
rs
data CanvasRenderState = CanvasRenderState
initialCanvasRenderState :: CanvasRenderState
initialCanvasRenderState :: CanvasRenderState
initialCanvasRenderState = CanvasRenderState
CanvasRenderState
getSize :: Options Canvas V2 Double -> SizeSpec V2 Double
getSize :: Options Canvas V2 Double -> SizeSpec V2 Double
getSize (CanvasOptions {_canvasSize :: Options Canvas V2 Double -> SizeSpec V2 Double
_canvasSize = SizeSpec V2 Double
s}) = SizeSpec V2 Double
s
setSize :: Options Canvas V2 Double -> (SizeSpec V2 Double) -> Options Canvas V2 Double
setSize :: Options Canvas V2 Double
-> SizeSpec V2 Double -> Options Canvas V2 Double
setSize Options Canvas V2 Double
o SizeSpec V2 Double
s = Options Canvas V2 Double
o {_canvasSize :: SizeSpec V2 Double
_canvasSize = SizeSpec V2 Double
s}
size :: Lens' (Options Canvas V2 Double)(SizeSpec V2 Double)
size :: Lens' (Options Canvas V2 Double) (SizeSpec V2 Double)
size = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Options Canvas V2 Double -> SizeSpec V2 Double
getSize Options Canvas V2 Double
-> SizeSpec V2 Double -> Options Canvas V2 Double
setSize
move :: (Double, Double) -> RenderM ()
move :: (Double, Double) -> RenderM ()
move (Double, Double)
p = do Lens' CanvasState (Double, Double)
csPos forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (Double, Double)
p
save :: RenderM ()
save :: RenderM ()
save = forall s (m :: * -> *). MonadStateStack s m => m ()
SS.save forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Canvas a -> RenderM a
liftC (() -> Canvas ()
BC.save ())
restore :: RenderM ()
restore :: RenderM ()
restore = forall a. Canvas a -> RenderM a
liftC (() -> Canvas ()
BC.restore ()) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadStateStack s m => m ()
SS.restore
newPath :: RenderM ()
newPath :: RenderM ()
newPath = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
BC.beginPath ()
closePath :: RenderM ()
closePath :: RenderM ()
closePath = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
BC.closePath ()
moveTo :: Double -> Double -> RenderM ()
moveTo :: Double -> Double -> RenderM ()
moveTo Double
x Double
y = do
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
BC.moveTo (Double
x, Double
y)
(Double, Double) -> RenderM ()
move (Double
x, Double
y)
relLineTo :: Double -> Double -> RenderM ()
relLineTo :: Double -> Double -> RenderM ()
relLineTo Double
x Double
y = do
(Double, Double)
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CanvasState (Double, Double)
csPos
let p' :: (Double, Double)
p' = (Double, Double)
p forall a. Num a => a -> a -> a
+ (Double
x, Double
y)
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Canvas ()
BC.lineTo (Double, Double)
p'
(Double, Double) -> RenderM ()
move (Double, Double)
p'
relCurveTo :: Double -> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo :: Double
-> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo Double
ax Double
ay Double
bx Double
by Double
cx Double
cy = do
(Double, Double)
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CanvasState (Double, Double)
csPos
let [(Double
ax',Double
ay'),(Double
bx',Double
by'),(Double
cx',Double
cy')] = forall a b. (a -> b) -> [a] -> [b]
map ((Double, Double)
p forall a. Num a => a -> a -> a
+) [(Double
ax,Double
ay),(Double
bx,Double
by),(Double
cx,Double
cy)]
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double, Double, Double) -> Canvas ()
BC.bezierCurveTo (Double
ax',Double
ay',Double
bx',Double
by',Double
cx',Double
cy')
(Double, Double) -> RenderM ()
move (Double
cx', Double
cy')
getStyleAttrib :: AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib :: forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib a -> b
f = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' CanvasState (Style V2 Double)
accumStyle
stroke :: RenderM ()
stroke :: RenderM ()
stroke = do
Double
w <- forall a. a -> Maybe a -> a
fromMaybe Double
0.5 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. LineWidth n -> n
getLineWidth
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
w forall a. Ord a => a -> a -> Bool
> (Double
0 :: Double)) (forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
BC.stroke ())
fill :: RenderM ()
fill :: RenderM ()
fill = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
BC.fill ()
clip :: RenderM ()
clip :: RenderM ()
clip = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ () -> Canvas ()
BC.clip ()
byteRange :: Double -> Word8
byteRange :: Double -> Word8
byteRange Double
d = forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
d forall a. Num a => a -> a -> a
* Double
255)
texture :: (forall a. S.Style a => a -> BC.Canvas ()) -> Texture Double -> Double -> RenderM()
texture :: (forall a. Style a => a -> Canvas ())
-> Texture Double -> Double -> RenderM ()
texture forall a. Style a => a -> Canvas ()
styleFn (SC (SomeColor c
c)) Double
o = forall a. Canvas a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Style a => a -> Canvas ()
styleFn forall a b. (a -> b) -> a -> b
$ Text
s
where s :: Text
s = forall c. Color c => c -> Double -> Text
showColorJS c
c Double
o
texture forall a. Style a => a -> Canvas ()
styleFn (LG LGradient Double
g) Double
_ = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ do
CanvasGradient
grd <- (Double, Double, Double, Double) -> Canvas CanvasGradient
BC.createLinearGradient (Double
x0, Double
y0, Double
x1, Double
y1)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Double, Text) -> CanvasGradient -> Canvas ()
BC.addColorStop forall a b. (a -> b) -> a -> b
$ CanvasGradient
grd) [(Double, Text)]
stops
forall a. Style a => a -> Canvas ()
styleFn CanvasGradient
grd
where
(Double
x0, Double
y0) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans) (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Point V2 n)
lGradStart)
(Double
x1, Double
y1) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Transformation V2 n)
lGradTrans) (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) (Point V2 n)
lGradEnd)
stops :: [(Double, Text)]
stops = forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop Double
s -> ( GradientStop Double
sforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) n
stopFraction , forall c. Color c => c -> Double -> Text
showColorJS (GradientStop Double
sforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) SomeColor
stopColor) Double
1)) (LGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (LGradient n) [GradientStop n]
lGradStops)
texture forall a. Style a => a -> Canvas ()
styleFn (RG RGradient Double
g) Double
_ = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ do
CanvasGradient
grd <- (Double, Double, Double, Double, Double, Double)
-> Canvas CanvasGradient
BC.createRadialGradient (Double
x0, Double
y0, Double
r0, Double
x1, Double
y1, Double
r1)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Double, Text) -> CanvasGradient -> Canvas ()
BC.addColorStop forall a b. (a -> b) -> a -> b
$ CanvasGradient
grd) [(Double, Text)]
stops
forall a. Style a => a -> Canvas ()
styleFn CanvasGradient
grd
where
(Double
r0, Double
r1) = (Double
s forall a. Num a => a -> a -> a
* RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) n
rGradRadius0, Double
s forall a. Num a => a -> a -> a
* RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) n
rGradRadius1)
(Double
x0, Double
y0) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans) (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter0)
(Double
x1, Double
y1) = forall n. P2 n -> (n, n)
unp2 forall a b. (a -> b) -> a -> b
$ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans) (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Point V2 n)
rGradCenter1)
stops :: [(Double, Text)]
stops = forall a b. (a -> b) -> [a] -> [b]
map (\GradientStop Double
st -> ( GradientStop Double
stforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) n
stopFraction , forall c. Color c => c -> Double -> Text
showColorJS (GradientStop Double
stforall s a. s -> Getting a s a -> a
^.forall n. Lens' (GradientStop n) SomeColor
stopColor) Double
1)) (RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) [GradientStop n]
rGradStops)
s :: Double
s = forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale forall a b. (a -> b) -> a -> b
$ RGradient Double
gforall s a. s -> Getting a s a -> a
^.forall n. Lens' (RGradient n) (Transformation V2 n)
rGradTrans
showColorJS :: (Color c) => c -> Double -> T.Text
showColorJS :: forall c. Color c => c -> Double -> Text
showColorJS c
c Double
o = [Text] -> Text
T.concat
[ Text
"rgba("
, Double -> Text
s (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
r), Text
","
, Double -> Text
s (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
g), Text
","
, Double -> Text
s (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
b), Text
","
, String -> Text
T.pack (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a) forall a. Num a => a -> a -> a
* Double
o)
, Text
")"
]
where s :: Double -> T.Text
s :: Double -> Text
s = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word8
byteRange
(Double
r,Double
g,Double
b,Double
a) = forall c. Color c => c -> (Double, Double, Double, Double)
colorToSRGBA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Color c => c -> AlphaColour Double
toAlphaColour forall a b. (a -> b) -> a -> b
$ c
c
canvasTransform :: T2 Double -> RenderM ()
canvasTransform :: Transformation V2 Double -> RenderM ()
canvasTransform Transformation V2 Double
tr = forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ (Double, Double, Double, Double, Double, Double) -> Canvas ()
BC.transform (Double, Double, Double, Double, Double, Double)
vs
where
[[Double
ax, Double
ay], [Double
bx, Double
by], [Double
tx, Double
ty]] = forall (v :: * -> *) n.
(Additive v, Traversable v, Num n) =>
Transformation v n -> [[n]]
matrixHomRep Transformation V2 Double
tr
vs :: (Double, Double, Double, Double, Double, Double)
vs = (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ax,forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ay
,forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
bx,forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
by
,forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
tx,forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
ty)
strokeTexture :: Texture Double -> Double -> RenderM ()
strokeTexture :: Texture Double -> Double -> RenderM ()
strokeTexture = (forall a. Style a => a -> Canvas ())
-> Texture Double -> Double -> RenderM ()
texture forall a. Style a => a -> Canvas ()
S.strokeStyle
fillTexture :: Texture Double -> Double -> RenderM ()
fillTexture :: Texture Double -> Double -> RenderM ()
fillTexture = (forall a. Style a => a -> Canvas ())
-> Texture Double -> Double -> RenderM ()
texture forall a. Style a => a -> Canvas ()
S.fillStyle
fromLineCap :: LineCap -> BC.LineEndCap
fromLineCap :: LineCap -> LineEndCap
fromLineCap LineCap
LineCapRound = LineEndCap
BC.RoundCap
fromLineCap LineCap
LineCapSquare = LineEndCap
BC.SquareCap
fromLineCap LineCap
_ = LineEndCap
BC.ButtCap
fromLineJoin :: LineJoin -> BC.LineJoinCorner
fromLineJoin :: LineJoin -> LineJoinCorner
fromLineJoin LineJoin
LineJoinRound = LineJoinCorner
BC.RoundCorner
fromLineJoin LineJoin
LineJoinBevel = LineJoinCorner
BC.BevelCorner
fromLineJoin LineJoin
_ = LineJoinCorner
BC.MiterCorner
showFontJS :: FontWeight -> FontSlant -> Double -> String -> T.Text
showFontJS :: FontWeight -> FontSlant -> Double -> String -> Text
showFontJS FontWeight
wgt FontSlant
slant Double
sz String
fnt = [Text] -> Text
T.concat [Text
a, Text
" ", Text
b, Text
" ", Text
c, Text
" ", Text
d]
where
a :: Text
a = case FontWeight
wgt of
FontWeight
FontWeightNormal -> Text
""
FontWeight
FontWeightBold -> Text
"bold"
FontWeight
_ -> Text
""
b :: Text
b = case FontSlant
slant of
FontSlant
FontSlantNormal -> Text
""
FontSlant
FontSlantItalic -> Text
"italic"
FontSlant
FontSlantOblique -> Text
"oblique"
c :: Text
c = [Text] -> Text
T.concat [String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Double
sz, Text
"pt"]
d :: Text
d = String -> Text
T.pack String
fnt
renderC :: (Renderable a Canvas, V a ~ V2, N a ~ Double) => a -> RenderM ()
renderC :: forall a.
(Renderable a Canvas, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC a
a = case (forall t b. Renderable t b => b -> t -> Render b (V t) (N t)
render Canvas
Canvas a
a) of C RenderM ()
r -> RenderM ()
r
canvasStyle :: Style v Double -> RenderM ()
canvasStyle :: forall (v :: * -> *). Style v Double -> RenderM ()
canvasStyle Style v Double
s = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [ forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle Clip Double -> RenderM ()
clip'
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineWidth Double -> RenderM ()
lWidth
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineCap -> RenderM ()
lCap
, forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle LineJoin -> RenderM ()
lJoin
]
where handle :: (AttributeClass a) => (a -> RenderM ()) -> Maybe (RenderM ())
handle :: forall a.
AttributeClass a =>
(a -> RenderM ()) -> Maybe (RenderM ())
handle a -> RenderM ()
f = a -> RenderM ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v Double
s
clip' :: Clip Double -> RenderM ()
clip' = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Path V2 Double
p -> Path V2 Double -> RenderM ()
canvasPath Path V2 Double
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
clip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Wrapped s => (Unwrapped s -> s) -> s -> Unwrapped s
op forall n. [Path V2 n] -> Clip n
Clip
lWidth :: LineWidth Double -> RenderM ()
lWidth = forall a. Canvas a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Canvas ()
BC.lineWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. LineWidth n -> n
getLineWidth
lCap :: LineCap -> RenderM ()
lCap = forall a. Canvas a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineEndCap -> Canvas ()
BC.lineCap forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineEndCap
fromLineCap forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineCap -> LineCap
getLineCap
lJoin :: LineJoin -> RenderM ()
lJoin = forall a. Canvas a -> RenderM a
liftC forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoinCorner -> Canvas ()
BC.lineJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoinCorner
fromLineJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineJoin -> LineJoin
getLineJoin
instance Renderable (Segment Closed V2 Double) Canvas where
render :: Canvas
-> Segment Closed V2 Double
-> Render
Canvas
(V (Segment Closed V2 Double))
(N (Segment Closed V2 Double))
render Canvas
_ (Linear (OffsetClosed (V2 Double
x Double
y))) = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ Double -> Double -> RenderM ()
relLineTo Double
x Double
y
render Canvas
_ (Cubic (V2 Double
x1 Double
y1)
(V2 Double
x2 Double
y2)
(OffsetClosed (V2 Double
x3 Double
y3)))
= RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ Double
-> Double -> Double -> Double -> Double -> Double -> RenderM ()
relCurveTo Double
x1 Double
y1 Double
x2 Double
y2 Double
x3 Double
y3
instance Renderable (Trail V2 Double) Canvas where
render :: Canvas
-> Trail V2 Double
-> Render Canvas (V (Trail V2 Double)) (N (Trail V2 Double))
render Canvas
_ = forall (v :: * -> *) n r.
(Trail' Line v n -> r) -> (Trail' Loop v n -> r) -> Trail v n -> r
withTrail Trail' Line V2 Double -> Render Canvas V2 Double
renderLine Trail' Loop V2 Double -> Render Canvas V2 Double
renderLoop
where
renderLine :: Trail' Line V2 Double -> Render Canvas V2 Double
renderLine Trail' Line V2 Double
ln = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Canvas, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments Trail' Line V2 Double
ln)
renderLoop :: Trail' Loop V2 Double -> Render Canvas V2 Double
renderLoop Trail' Loop V2 Double
lp = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ do
case forall (v :: * -> *) n.
Trail' Loop v n -> ([Segment Closed v n], Segment Open v n)
loopSegments Trail' Loop V2 Double
lp of
([Segment Closed V2 Double]
segs, Linear Offset Open V2 Double
_) -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Canvas, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC [Segment Closed V2 Double]
segs
([Segment Closed V2 Double], Segment Open V2 Double)
_ -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a.
(Renderable a Canvas, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC (forall (v :: * -> *) n. Trail' Line v n -> [Segment Closed v n]
lineSegments forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Trail' Loop v n -> Trail' Line v n
cutLoop forall a b. (a -> b) -> a -> b
$ Trail' Loop V2 Double
lp)
RenderM ()
closePath
instance Renderable (Path V2 Double) Canvas where
render :: Canvas
-> Path V2 Double
-> Render Canvas (V (Path V2 Double)) (N (Path V2 Double))
render Canvas
_ Path V2 Double
p = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ do
Path V2 Double -> RenderM ()
canvasPath Path V2 Double
p
Maybe (Texture Double)
f <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FillTexture n -> Texture n
getFillTexture
Maybe (Texture Double)
s <- forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. LineTexture n -> Texture n
getLineTexture
Double
o <- forall a. a -> Maybe a -> a
fromMaybe Double
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Opacity -> Double
getOpacity
RenderM ()
save
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (Texture Double)
f) (Texture Double -> Double -> RenderM ()
fillTexture (forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Texture Double)
f) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
o) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RenderM ()
fill)
Texture Double -> Double -> RenderM ()
strokeTexture (forall a. a -> Maybe a -> a
fromMaybe (forall n. SomeColor -> Texture n
SC (forall c. Color c => c -> SomeColor
SomeColor (forall a. Num a => Colour a
black :: Colour Double))) Maybe (Texture Double)
s) (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
o)
RenderM ()
stroke
RenderM ()
restore
canvasPath :: Path V2 Double -> RenderM ()
canvasPath :: Path V2 Double -> RenderM ()
canvasPath (Path [Located (Trail V2 Double)]
trs) = do
RenderM ()
newPath
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ forall {a}.
(V a ~ V2, N a ~ Double, Renderable a Canvas) =>
Located a -> RenderM ()
renderTrail [Located (Trail V2 Double)]
trs
where
renderTrail :: Located a -> RenderM ()
renderTrail (forall a. Located a -> (Point (V a) (N a), a)
viewLoc -> (forall n. P2 n -> (n, n)
unp2 -> (Double, Double)
p, a
tr)) = do
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> RenderM ()
moveTo (Double, Double)
p
forall a.
(Renderable a Canvas, V a ~ V2, N a ~ Double) =>
a -> RenderM ()
renderC a
tr
instance Renderable (Text Double) Canvas where
render :: Canvas
-> Text Double -> Render Canvas (V (Text Double)) (N (Text Double))
render Canvas
_ (Text Transformation V2 Double
tr TextAlignment Double
al String
str) = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ do
String
tf <- forall a. a -> Maybe a -> a
fromMaybe String
"Calibri" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Font -> String
getFont
Double
sz <- forall a. a -> Maybe a -> a
fromMaybe Double
12 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FontSize n -> n
getFontSize
FontSlant
slant <- forall a. a -> Maybe a -> a
fromMaybe FontSlant
FontSlantNormal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FontSlant -> FontSlant
getFontSlant
FontWeight
fw <- forall a. a -> Maybe a -> a
fromMaybe FontWeight
FontWeightNormal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib FontWeight -> FontWeight
getFontWeight
Texture Double
tx <- forall a. a -> Maybe a -> a
fromMaybe (forall n. SomeColor -> Texture n
SC (forall c. Color c => c -> SomeColor
SomeColor (forall a. Num a => Colour a
black :: Colour Double)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib forall n. FillTexture n -> Texture n
getFillTexture
Double
o <- forall a. a -> Maybe a -> a
fromMaybe Double
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. AttributeClass a => (a -> b) -> RenderM (Maybe b)
getStyleAttrib Opacity -> Double
getOpacity
let fSize :: Double
fSize = forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation V2 Double
tr forall a. Num a => a -> a -> a
* Double
sz
fnt :: Text
fnt = FontWeight -> FontSlant -> Double -> String -> Text
showFontJS FontWeight
fw FontSlant
slant Double
fSize String
tf
vAlign :: TextBaselineAlignment
vAlign = case TextAlignment Double
al of
TextAlignment Double
BaselineText -> TextBaselineAlignment
BC.AlphabeticBaseline
BoxAlignedText Double
_ Double
h -> case Double
h of
Double
h' | Double
h' forall a. Ord a => a -> a -> Bool
<= Double
0.25 -> TextBaselineAlignment
BC.BottomBaseline
Double
h' | Double
h' forall a. Ord a => a -> a -> Bool
>= Double
0.75 -> TextBaselineAlignment
BC.TopBaseline
Double
_ -> TextBaselineAlignment
BC.MiddleBaseline
hAlign :: TextAnchorAlignment
hAlign = case TextAlignment Double
al of
TextAlignment Double
BaselineText -> TextAnchorAlignment
BC.StartAnchor
BoxAlignedText Double
w Double
_ -> case Double
w of
Double
w' | Double
w' forall a. Ord a => a -> a -> Bool
<= Double
0.25 -> TextAnchorAlignment
BC.StartAnchor
Double
w' | Double
w' forall a. Ord a => a -> a -> Bool
>= Double
0.75 -> TextAnchorAlignment
BC.EndAnchor
Double
_ -> TextAnchorAlignment
BC.CenterAnchor
RenderM ()
save
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ TextBaselineAlignment -> Canvas ()
BC.textBaseline TextBaselineAlignment
vAlign
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ TextAnchorAlignment -> Canvas ()
BC.textAlign TextAnchorAlignment
hAlign
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Text -> Canvas ()
BC.font Text
fnt
Texture Double -> Double -> RenderM ()
fillTexture Texture Double
tx (forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
o)
Transformation V2 Double -> RenderM ()
canvasTransform (Transformation V2 Double
tr forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY)
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ (Text, Double, Double) -> Canvas ()
BC.fillText (String -> Text
T.pack String
str, Double
0, Double
0)
RenderM ()
restore
instance Renderable (DImage Double External) Canvas where
render :: Canvas
-> DImage Double External
-> Render
Canvas (V (DImage Double External)) (N (DImage Double External))
render Canvas
_ (DImage ImageData External
path Int
w Int
h Transformation V2 Double
tr) = RenderM () -> Render Canvas V2 Double
C forall a b. (a -> b) -> a -> b
$ do
let ImageRef String
file = ImageData External
path
RenderM ()
save
Transformation V2 Double -> RenderM ()
canvasTransform (Transformation V2 Double
tr forall a. Semigroup a => a -> a -> a
<> forall (v :: * -> *) n.
(Additive v, R2 v, Num n) =>
Transformation v n
reflectionY)
CanvasImage
img <- forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ Text -> Canvas CanvasImage
BC.newImage (String -> Text
T.pack String
file)
forall a. Canvas a -> RenderM a
liftC forall a b. (a -> b) -> a -> b
$ forall image. Image image => (image, [Double]) -> Canvas ()
BC.drawImage (CanvasImage
img, [forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
w) forall a. Fractional a => a -> a -> a
/ Double
2, forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Int
h) forall a. Fractional a => a -> a -> a
/ Double
2, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h])
RenderM ()
restore
renderCanvas :: Int -> SizeSpec V2 Double -> QDiagram Canvas V2 Double Any -> IO ()
renderCanvas :: Int -> SizeSpec V2 Double -> QDiagram Canvas V2 Double Any -> IO ()
renderCanvas Int
port SizeSpec V2 Double
sizeSpec QDiagram Canvas V2 Double Any
d = Options -> (DeviceContext -> IO ()) -> IO ()
BC.blankCanvas (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. DeviceContext -> Canvas a -> IO a
BC.send forall a b. (a -> b) -> a -> b
$ Result Canvas V2 Double
img
where
img :: Result Canvas V2 Double
img = forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia Canvas
Canvas (SizeSpec V2 Double -> Options Canvas V2 Double
CanvasOptions SizeSpec V2 Double
sizeSpec) QDiagram Canvas V2 Double Any
d