module Diagrams.Backend.HsQML.DiagramObj.Commands where
import Diagrams.Backend.HsQML.GradientObj
import Diagrams.Backend.HsQML.DiagramObj.Type
import qualified Diagrams.Backend.HsQML.DiagramObj.Signals as S
import Data.Text (pack)
import Control.Lens hiding (over)
import Control.Monad (forM_)
import Control.Monad.IO.Class
import Data.Colour
import Data.Colour.SRGB
import Diagrams.Prelude hiding (over)
import Diagrams.TwoD.Attributes
import Diagrams.TwoD.Text
import Graphics.QML
save :: DiagramObj ()
save = DiagramObj $ fireSignal S.save
restore :: DiagramObj ()
restore = DiagramObj $ fireSignal S.restore
text :: String -> Double -> Double -> DiagramObj ()
text txt x y = DiagramObj $ \this -> fireSignal S.renderText this (pack txt) x y
beginPath :: DiagramObj ()
beginPath = DiagramObj $ fireSignal S.beginPath
closePath :: DiagramObj ()
closePath = DiagramObj $ fireSignal S.closePath
moveTo :: P2 Double -> DiagramObj ()
moveTo p = let (x,y) = unp2 p in DiagramObj $ \this -> fireSignal S.moveTo this x y
stroke :: DiagramObj ()
stroke = DiagramObj $ fireSignal S.stroke
fill :: DiagramObj ()
fill = DiagramObj $ fireSignal S.fill
lineTo :: P2 Double -> DiagramObj ()
lineTo p = DiagramObj $ \this -> fireSignal S.lineTo this x y
where (x,y) = unp2 p
bezierCurveTo
:: P2 Double
-> P2 Double
-> P2 Double
-> DiagramObj ()
bezierCurveTo cp1 cp2 p = DiagramObj $ \this ->
fireSignal S.bezierCurveTo this cp1x cp1y cp2x cp2y x y
where (cp1x, cp1y) = unp2 cp1
(cp2x, cp2y) = unp2 cp2
( x, y) = unp2 p
setLineCap :: LineCap -> DiagramObj ()
setLineCap cap = DiagramObj $ \this -> fireSignal S.setLineCap this . pack $
case cap of
LineCapButt -> "butt"
LineCapRound -> "round"
LineCapSquare -> "square"
setLineJoin :: LineJoin -> DiagramObj ()
setLineJoin j = DiagramObj $ \this -> fireSignal S.setLineJoin this . pack $
case j of
LineJoinMiter -> "miter"
LineJoinRound -> "round"
LineJoinBevel -> "bevel"
setLineMiterLimit :: LineMiterLimit -> DiagramObj ()
setLineMiterLimit m = DiagramObj $ \this -> fireSignal S.setLineMiterLimit this (getLineMiterLimit m)
setOpacity :: Opacity -> DiagramObj ()
setOpacity o = DiagramObj $ \this -> fireSignal S.setGlobalAlpha this (getOpacity o)
setLineWidth :: LineWidth Double -> DiagramObj ()
setLineWidth w = DiagramObj $ \this -> fireSignal S.setLineWidth this (getLineWidth w)
getRGBA :: SomeColor -> (Double, Double, Double, Double)
getRGBA c = (r,g,b,a)
where RGB r g b = toSRGB (ac `over` black)
a = alphaChannel ac
ac = someToAlpha c
getLinearGradient :: LGradient Double -> DiagramObj (ObjRef GradientObj)
getLinearGradient lg = DiagramObj $ \this -> do
g <- newGradient
fireSignal S.connectLinearGradient this g x0 y0 x1 y1
return g
where (x0,y0) = unp2.papply (lg^.lGradTrans) $ lg^.lGradStart
(x1,y1) = unp2.papply (lg^.lGradTrans) $ lg^.lGradEnd
getRadialGradient :: RGradient Double -> DiagramObj (ObjRef GradientObj)
getRadialGradient rg = DiagramObj $ \this -> do
g <- newGradient
fireSignal S.connectRadialGradient this g x0 y0 r0 x1 y1 r1
return g
where (x0,y0) = unp2.papply (rg^.rGradTrans) $ rg^.rGradCenter0
(x1,y1) = unp2.papply (rg^.rGradTrans) $ rg^.rGradCenter1
r0 = rg^.rGradRadius0
r1 = rg^.rGradRadius1
setStrokeColour :: SomeColor -> DiagramObj ()
setStrokeColour c = DiagramObj $ \this -> fireSignal S.setStrokeColour this r g b a
where (r,g,b,a) = getRGBA c
setLineGradient :: DiagramObj ()
setLineGradient = DiagramObj $ fireSignal S.setLineGradient
setLineTexture :: LineTexture Double -> DiagramObj ()
setLineTexture tex =
case getLineTexture tex of
SC c -> setStrokeColour c
LG l -> getLinearGradient l >>= liftIO.(setGradient $ l^.lGradStops) >> setLineGradient
RG r -> getRadialGradient r >>= liftIO.(setGradient $ r^.rGradStops) >> setLineGradient
setGradient :: [GradientStop Double] -> ObjRef GradientObj -> IO ()
setGradient stops grad = forM_ stops
$ \stop -> let (r,g,b,a) = getRGBA (stop^.stopColor)
o = stop^.stopFraction
in addColourStop grad r g b a o
setFillColour :: SomeColor -> DiagramObj ()
setFillColour c = DiagramObj $ \this -> fireSignal S.setFillColour this r g b a
where (r,g,b,a) = getRGBA c
setFillGradient :: DiagramObj ()
setFillGradient = DiagramObj $ fireSignal S.setFillGradient
setFillTexture :: FillTexture Double -> DiagramObj ()
setFillTexture tex =
case getFillTexture tex of
SC c -> setFillColour c
LG l -> getLinearGradient l >>= liftIO.(setGradient $ l^.lGradStops) >> setFillGradient
RG r -> getRadialGradient r >>= liftIO.(setGradient $ r^.rGradStops) >> setFillGradient
setFont :: Font -> DiagramObj ()
setFont f = DiagramObj $ \this -> fireSignal S.setFont this (pack $ getFont f)
setFillRule :: FillRule -> DiagramObj ()
setFillRule EvenOdd = DiagramObj $ fireSignal S.oddEvenFill
setFillRule Winding = DiagramObj $ fireSignal S.windingFill