Commands.hs

{-|
Module      : Diagrams.Backend.HsQML.DiagramObj.Commands
Description : Functions to create a DiagramObj containing a single command.
Copyright   : (c) Marcin Mrotek, 2015
License     : BSD-3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

As 'DiagramObj' is a 'Monoid', complex diagrams may be optained by 'mappend'ing simple ones together.
This module provides functions creating 'DiagramObj's containing a single command each.
-}

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
import Diagrams.TwoD.Attributes
import Diagrams.TwoD.Text
import Graphics.QML

save :: DiagramObj ()
-- ^Push the current state (style, font, etc) onto the state stack.
save = DiagramObj $ fireSignal S.save

restore :: DiagramObj ()
-- ^Pop the current state (style, font, etc) from the state stack.
restore = DiagramObj $ fireSignal S.restore

text :: String -> Double -> Double -> DiagramObj ()
-- ^Display text on a specified point.
text txt x y = DiagramObj $ \this -> fireSignal S.renderText this (pack txt) x y

beginPath :: DiagramObj ()
-- ^Start assembling a new path.
beginPath = DiagramObj $ fireSignal S.beginPath

closePath :: DiagramObj ()
-- ^Connect the current path vertex to the start of the path.
closePath = DiagramObj $ fireSignal S.closePath

moveTo :: P2 -> DiagramObj ()
-- ^Change the current position.
moveTo p = let (x,y) = unp2 p in DiagramObj $ \this -> fireSignal S.moveTo this x y

stroke :: DiagramObj ()
-- ^Stroke the current path.
stroke = DiagramObj $ fireSignal S.stroke

fill :: DiagramObj ()
-- ^Fill the current path. Works only on paths that were previously 'close'd.
fill = DiagramObj $ fireSignal S.fill

lineTo :: P2 -> DiagramObj ()
-- ^Draw a straight line from the current position to a given point.
lineTo p = DiagramObj $ \this -> fireSignal S.lineTo this x y
  where (x,y) = unp2 p

bezierCurveTo 
  :: P2 -- ^First control point.
  -> P2 -- ^Second control point
  -> P2 -- ^End point.
   -> DiagramObj () 
-- ^Draw a bezier curve from the current position to a given point, using two control points.
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 ()
-- ^Set the line cap style.
setLineCap cap = DiagramObj $ \this -> fireSignal S.setLineCap this . pack $
   case cap of
     LineCapButt   -> "butt"
     LineCapRound  -> "round"
     LineCapSquare -> "square"

setLineJoin :: LineJoin -> DiagramObj ()
-- ^Set the line join style.
setLineJoin j = DiagramObj $ \this -> fireSignal S.setLineJoin this . pack $
   case j of
     LineJoinMiter -> "miter"
     LineJoinRound -> "round"
     LineJoinBevel -> "bevel"

setLineMiterLimit :: LineMiterLimit -> DiagramObj ()
-- ^Set the miter limit.
setLineMiterLimit m = DiagramObj $ \this -> fireSignal S.setLineMiterLimit this (getLineMiterLimit m)

setOpacity :: Opacity -> DiagramObj ()
-- ^Set the global alpha (subject to 'save' and 'restore').
setOpacity o = DiagramObj $ \this -> fireSignal S.setGlobalAlpha this (getOpacity o)

setLineWidth :: LineWidth -> DiagramObj ()
-- ^Set the line width (output coordinates assumed).
setLineWidth w = DiagramObj $ \this -> fireSignal S.setLineWidth this (fromOutput $ getLineWidth w)

getRGBA :: SomeColor -> (Double, Double, Double, Double)
-- ^Convert a colour to a tuple of (r,g,b,a) components.
getRGBA c = (r,g,b,a)
  where RGB r g b = fromIntegral <$> toSRGB24 (ac `over` black)
        a = alphaChannel ac
        ac = toAlphaColour c

getLinearGradient :: LGradient -> DiagramObj (ObjRef GradientObj)
-- ^Created a linear gradient.
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 -> DiagramObj (ObjRef GradientObj)
-- ^Create a radial gradient.
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 ()
-- ^Set stroke style to a flat colour.
setStrokeColour c = DiagramObj $ \this -> fireSignal S.setStrokeColour this r g b a 
   where (r,g,b,a) = getRGBA c

setLineGradient :: DiagramObj ()
-- ^Set stroke style to a previously assembled gradient.
setLineGradient = DiagramObj $ fireSignal S.setLineGradient

setLineTexture :: LineTexture -> DiagramObj ()
-- ^Set stroke style.
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] -> ObjRef GradientObj -> IO ()
-- ^Add colour stops to a gradient.
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 ()
-- ^Set fill style to a flat colour.
setFillColour c = DiagramObj $ \this -> fireSignal S.setFillColour this r g b a 
  where (r,g,b,a) = getRGBA c

setFillGradient :: DiagramObj ()
-- ^Set fill style to a previously defined gradient.
setFillGradient = DiagramObj $ fireSignal S.setFillGradient

setFillTexture :: FillTexture -> DiagramObj ()
-- ^Set fill style.
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 ()
-- ^Set font.
setFont f = DiagramObj $ \this -> fireSignal S.setFont this (pack $ getFont f)

setFillRule :: FillRule -> DiagramObj ()
-- ^Set fill rule.
setFillRule EvenOdd = DiagramObj $ fireSignal S.oddEvenFill
setFillRule Winding = DiagramObj $ fireSignal S.windingFill