-- | Cairo rendering for 'P.Image' from @hps@.
module Graphics.PS.Cairo (renderImage, cg) where

import Data.IORef
import Graphics.PS as P
import Graphics.PS.Matrix as P
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as C
import qualified Graphics.UI.Gtk as G

applyMatrix :: Matrix -> C.Render ()
applyMatrix (Matrix a b c d e f) = C.transform (C.Matrix a b c d e f)

applyFont :: Font -> C.Render ()
applyFont (Font nm sz) = do
  C.selectFontFace nm C.FontSlantNormal C.FontWeightNormal
  C.setFontSize sz

renderPath :: P.Path -> C.Render ()
renderPath path =
    case path of
      P.MoveTo (Pt x y) -> C.moveTo x y
      P.LineTo (Pt x y) -> C.lineTo x y
      P.CurveTo (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) ->
          C.curveTo x1 y1 x2 y2 x3 y3
      P.ClosePath (Pt x y) -> C.lineTo x y >> C.closePath
      P.Text f t -> applyFont f >> C.textPath t
      P.PTransform m p ->
          C.save >> applyMatrix m >> renderPath p >> C.restore
      P.Join p1 p2 -> renderPath p1 >> renderPath p2

setGS :: GS -> C.Render ()
setGS (GS (RGB r g b) w k j _ _) = do
  C.setSourceRGBA r g b 0.75
  C.setLineWidth w
  C.setLineCap (lineCap k)
  C.setLineJoin (lineJoin j)

-- | Render an 'P.Image' in cairo.
renderImage :: P.Image -> C.Render ()
renderImage image =
    case image of
      P.Empty -> return ()
      P.Stroke g p -> renderPath p >> setGS g >> C.stroke
      P.Fill g p -> renderPath p >> setGS g >> C.fillPreserve >> C.stroke
      P.ITransform m i -> C.save >> applyMatrix m >> renderImage i >> C.restore
      P.Over i1 i2 -> renderImage i1 >> renderImage i2

lineCap :: LineCap -> C.LineCap
lineCap c =
    case c of
      RoundCap -> C.LineCapRound
      ButtCap -> C.LineCapButt
      ProjectingSquareCap -> C.LineCapSquare

lineJoin :: LineJoin -> C.LineJoin
lineJoin j =
    case j of
      MiterJoin -> C.LineJoinMiter
      RoundJoin -> C.LineJoinRound
      BevelJoin -> C.LineJoinBevel

cg' :: String -> Paper -> [P.Image] -> IO ()
cg' _ (Paper w h) pp = do
  _ <- G.initGUI
  window <- G.windowNew
  canvas <- G.drawingAreaNew
  n <- newIORef 0
  G.windowSetResizable window False
  G.widgetSetSizeRequest window w h
  _ <- G.onKeyPress window (\_ -> modifyIORef n (+ 1) >>
                                  G.widgetQueueDraw window >>
                                  return True)
  _ <- G.onDestroy window G.mainQuit
  _ <- G.onExpose canvas (const (updateCanvas n canvas pp))
  G.set window [G.containerChild G.:= canvas]
  G.widgetShowAll window
  G.mainGUI

updateCanvas :: (G.WidgetClass w) =>
                IORef Int -> w -> [P.Image] -> IO Bool
updateCanvas n canvas pp = do
  window <- G.widgetGetDrawWindow canvas
  k <- readIORef n
  G.renderWithDrawable window (renderImage (cycle pp !! k))
  return True

p_xflip :: Int -> P.Path -> P.Path
p_xflip x path =
    case path of
      P.Join p q -> P.Join (p_xflip x p) (p_xflip x q)
      P.Text f s ->
          let m = P.Matrix 1.0 0.0 0.0 1.0 0.0 (fromIntegral x)
          in P.PTransform m (P.Text f s)
      _ ->
          let m = P.Matrix 1.0 0.0 0.0 (-1.0) 0.0 (fromIntegral x)
          in P.PTransform m path

i_xflip :: Int -> P.Image -> P.Image
i_xflip x image =
    case image of
      P.Stroke g p -> P.Stroke g (p_xflip x p)
      P.Fill g p -> P.Fill g (p_xflip x p)
      P.ITransform m i -> P.ITransform m (i_xflip x i)
      P.Over i j -> P.Over (i_xflip x i) (i_xflip x j)
      P.Empty -> P.Empty

-- | Cairo rendering variant of 'P.ps'.
cg :: String -> Paper -> [P.Image] -> IO ()
cg fn (Paper w h) pp = cg' fn (Paper w h) (map (i_xflip h) pp)