-- | Cairo backend to Hieroglyph.  Future plans include making 'StateModifier' part 
--   of the base distribution and making 'Frame' the basis for all backends to 
--   Hieroglyph.  The real challenge will be making all implementations /look/ the
--   same.
--
--   Note in particular that pattern functionality and Pango layouts and font
--   rendering engines are not implemented yet.  This is both because these
--   features are fairly complicated, and because I haven't figured out yet
--   how I might make them portable to OpenGL using textures and FTGL.  if 
--   someone wants to take this task on, I'd be pleased as punch.
--
--      [@Author@] Jeff Heard
--      
--      [@Copyright@] © 2008 Renaissance Computing Institute
--      
--      [@License@] A LICENSE file should be included as part of this distribution
--
--      [@Version@] 0.5
--
module Graphics.Rendering.Hieroglyph.Cairo where

import Data.Map (Map)
import qualified Data.Map as M
import System.Mem.Weak
import Control.Concurrent
import Control.Monad.Trans (liftIO)
import Graphics.Rendering.Hieroglyph.Primitives
import Graphics.Rendering.Hieroglyph.ImageCache
import Graphics.Rendering.Hieroglyph.Visual
import Graphics.UI.Gtk.Gdk.Pixbuf 
import qualified Graphics.UI.Gtk.Cairo as Cairo
import qualified Graphics.Rendering.Cairo as Cairo
import Control.Monad
import Control.Monad.IfElse
import Data.Foldable (foldlM)
import Data.List (sort)

toCairoFontSlant FontSlantNormal = Cairo.FontSlantNormal
toCairoFontSlant FontSlantItalic = Cairo.FontSlantItalic
toCairoFontSlant FontSlantOblique = Cairo.FontSlantOblique

toCairoFontWeight FontWeightNormal = Cairo.FontWeightNormal
toCairoFontWeight FontWeightBold = Cairo.FontWeightBold

toCairoAntialias AntialiasDefault = Cairo.AntialiasDefault 
toCairoAntialias AntialiasNone = Cairo.AntialiasNone 
toCairoAntialias AntialiasGray = Cairo.AntialiasGray 
toCairoAntialias AntialiasSubpixel = Cairo.AntialiasSubpixel 

toCairoFillRule FillRuleWinding = Cairo.FillRuleWinding 
toCairoFillRule FillRuleEvenOdd = Cairo.FillRuleEvenOdd

toCairoLineCap LineCapButt = Cairo.LineCapButt 
toCairoLineCap LineCapRound = Cairo.LineCapRound 
toCairoLineCap LineCapSquare = Cairo.LineCapSquare 

toCairoLineJoin LineJoinMiter = Cairo.LineJoinMiter 
toCairoLineJoin LineJoinRound = Cairo.LineJoinRound 
toCairoLineJoin LineJoinBevel = Cairo.LineJoinBevel 

toCairoOperator OperatorClear = Cairo.OperatorClear
toCairoOperator OperatorSource = Cairo.OperatorSource
toCairoOperator OperatorOver = Cairo.OperatorOver
toCairoOperator OperatorIn = Cairo.OperatorIn
toCairoOperator OperatorOut = Cairo.OperatorOut
toCairoOperator OperatorAtop = Cairo.OperatorAtop
toCairoOperator OperatorDest = Cairo.OperatorDest
toCairoOperator OperatorXor = Cairo.OperatorXor
toCairoOperator OperatorAdd = Cairo.OperatorAdd
toCairoOperator OperatorSaturate = Cairo.OperatorSaturate

fillStrokeAndClip state = do 
    let (fr,fg,fb,fa) = fillRGBA state
        (sr,sg,sb,sa) = strokeRGBA state
    when (filled state) $     
        Cairo.setSourceRGBA fr fg fb fa >> 
        if (outlined state) then Cairo.fillPreserve else Cairo.fill
    when (outlined state) $ 
        Cairo.setSourceRGBA sr sg sb sa >>
        Cairo.stroke
    when (clipped state) $ Cairo.clip

renderCurveSegs (Line (Point x0 y0)) = Cairo.lineTo x0 y0
renderCurveSegs (EndPoint (Point x0 y0)) = Cairo.moveTo x0 y0
renderCurveSegs (Spline (Point x0 y0) (Point x1 y1) (Point x2 y2)) = Cairo.curveTo x0 y0 x1 y1 x2 y2 

-- | @renderPrimitive state prim@ draws a single primitive.
renderPrimitive :: ImageCache -> Attributes -> Primitive -> Cairo.Render Attributes
renderPrimitive _ s0 (Arc (Point cx cy) radius angle0 angle1 isnegative state) = do 
    applyAttributeDelta s0 state   
    if isnegative 
        then Cairo.arcNegative cx cy radius angle0 angle1 
        else Cairo.arc cx cy radius angle0 angle1
    fillStrokeAndClip state
    return state

renderPrimitive _ s0 (Path (Point ox oy) segs isclosed state) = do 
    applyAttributeDelta s0 state
    Cairo.moveTo ox oy
    forM_ segs $ renderCurveSegs
    when isclosed (Cairo.lineTo ox oy)
    fillStrokeAndClip state
    return state

renderPrimitive images s0 i@(Image filename (Left (Point ox oy)) _ state) = do
    applyAttributeDelta s0 state
    pbuf <- loadImage images i
    w <- liftIO $ pixbufGetWidth pbuf
    h <- liftIO $ pixbufGetHeight pbuf
    Cairo.save
    Cairo.setSourcePixbuf pbuf ox oy
    Cairo.rectangle ox oy (fromIntegral w) (fromIntegral h)
    Cairo.fill
    Cairo.restore
    return state

renderPrimitive images s0 i@(Image filename (Right (Rect ox oy w h)) _ state) = do
    applyAttributeDelta s0 state
    pbuf <- loadImage images i
    Cairo.save
    Cairo.setSourcePixbuf pbuf ox oy
    Cairo.rectangle ox oy w h
    Cairo.fill
    Cairo.restore
    return state

renderPrimitive _ s0 (Hidden _) = return s0
renderPrimitive _ s0 (Rectangle (Point ox oy) w h state) = do 
    applyAttributeDelta s0 state
    Cairo.rectangle ox oy w h 
    fillStrokeAndClip state
    return state
    
renderPrimitive _ s0 (Text str (Point ox oy) state) = do
    applyAttributeDelta s0 state 
    Cairo.moveTo ox oy
    Cairo.showText str 
    fillStrokeAndClip state
    return state
    
renderPrimitive images s0 (Union prims state) = do
    let unfoc prim = prim{ attribs = (attribs prim){filled=False, outlined=False, clipped=False } }
    applyAttributeDelta s0 state
    mapM_ (renderPrimitive images state . unfoc) prims >> fillStrokeAndClip state
    return state
    
render images d = loadStateIntoCairo attrs0
                    >> (foldlM (renderPrimitive images) attrs0 . sort $ vis)
                    >> return ()
    where vis = primitives d 
          attrs0 = attribs . head $ vis       
    
applyAttributeDelta a b = do
    let different f = ((f %=> (/=)) a b)
        whendifferent f = when (different f)
    when (different fontfamily || different fontslant || different fontweight) $ Cairo.selectFontFace (fontfamily b) (toCairoFontSlant . fontslant $ b) (toCairoFontWeight . fontweight $ b)
    whendifferent fillrule . Cairo.setFillRule . toCairoFillRule . fillrule $ b
    whendifferent dash . maybe (return ()) (uncurry Cairo.setDash) . dash $ b
    whendifferent antialias . Cairo.setAntialias . toCairoAntialias . antialias $ b
    whendifferent linecap . Cairo.setLineCap . toCairoLineCap . linecap $ b
    whendifferent linejoin . Cairo.setLineJoin . toCairoLineJoin . linejoin $ b
    whendifferent miterlimit . Cairo.setMiterLimit .  miterlimit $ b
    whendifferent tolerance . Cairo.setTolerance . tolerance $ b
    whendifferent operator . Cairo.setOperator . toCairoOperator . operator $ b
    when (different scalex || different scaley || different rotation || different translatex || different translatey) $ do
        Cairo.translate (translatex b) (translatey b)
        Cairo.scale (scalex b) (scaley b)
        Cairo.rotate (rotation b)
    return b        
      
-- | Load the Cairo state  with a 'RenderState' Drawing.
loadStateIntoCairo :: Attributes -> Cairo.Render ()
loadStateIntoCairo s = do
    Cairo.selectFontFace (fontfamily s) (toCairoFontSlant . fontslant $ s) (toCairoFontWeight . fontweight $ s)
    Cairo.setFillRule . toCairoFillRule . fillrule $ s
    awhen (dash s) $ \(a,b) -> Cairo.setDash a b
    Cairo.setAntialias . toCairoAntialias . antialias $ s
  
    Cairo.setLineJoin . toCairoLineJoin . linejoin $ s
    Cairo.setLineWidth . linewidth $ s
    Cairo.setMiterLimit . miterlimit $ s
    Cairo.setTolerance . tolerance $ s
    Cairo.setOperator . toCairoOperator . operator $ s
    
    Cairo.translate (translatex s) (translatey s)
    Cairo.scale (scalex s) (scaley s)
    Cairo.rotate (rotation s)

-- | @renderFrameToSurface surface frame@ renders a frame to a particular surface
renderToSurfaceWithImageCache :: Visual t => ImageCache -> Cairo.Surface -> t -> IO ()
renderToSurfaceWithImageCache images surf frame = Cairo.renderWith surf (render images frame)

renderToSurface :: Visual t => Cairo.Surface -> t -> IO ()
renderToSurface s o = do { i <- initImageCache; renderToSurfaceWithImageCache i s o }

-- | @renderframeToPNGWithImageCache  filename xres yres frame@ renders a frame to an image file
renderToPNGWithImageCache  :: Visual t => ImageCache -> FilePath -> Int -> Int -> t -> IO ()
renderToPNGWithImageCache images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderToSurfaceWithImageCache images s frame >> Cairo.surfaceWriteToPNG s filename
renderToPNG f w h o = do { i <- initImageCache ; renderToPNGWithImageCache i f w h o }

-- | @renderToPDFWithImageCache  filename width height frame@ renders a frame to a PDF file.  width and height are in points.
renderToPDFWithImageCache  :: Visual t => ImageCache -> FilePath -> Double -> Double -> t -> IO ()
renderToPDFWithImageCache images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderToSurfaceWithImageCache images s frame
renderToPDF f w h o = do { i <- initImageCache ; renderToPDFWithImageCache i f w h o } 

-- | @renderToPostscriptWithImageCache  filename width height frame@ renders a frame to a Postscript file.  width and height are in points.
renderToPostscriptWithImageCache  :: Visual t => ImageCache -> FilePath -> Double -> Double -> t -> IO ()
renderToPostscriptWithImageCache  images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderToSurfaceWithImageCache images s frame
renderToPostscript f w h o = do { i <- initImageCache ; renderToPostscriptWithImageCache i f w h o }

-- | @renderToSVGWithImageCache  filename width height frame@ renders a frame to a SVG file.  width and height are in points.
renderToSVGWithImageCache  :: Visual t => ImageCache -> FilePath -> Double -> Double -> t -> IO ()
renderToSVGWithImageCache images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderToSurfaceWithImageCache images s frame
renderToSVG f w h o = do { i <- initImageCache ; renderToSVGWithImageCache i f w h o }

-- | @loadImage dictRef image@ pulls an image out of the cache's hat.
loadImage :: ImageCache -> Primitive -> Cairo.Render (Pixbuf)
loadImage dictRef im@(Image filename (Right (Rect x y w h)) aspect _) = do
  liftIO $ modifyMVar dictRef $ \dict -> 
    if (show im) `M.member` dict
      then do value <- deRefWeak $ dict M.! (show im)
              pbuf <- case value of
                          Just pb -> return pb 
                          Nothing -> pixbufNewFromFileAtScale filename (round w) (round h) aspect
              return (dict,pbuf)
      else do pbuf <- pixbufNewFromFileAtScale filename (round w) (round h) aspect
              wk <-  mkWeakPtr pbuf Nothing
              return ((M.insert (show im) wk dict), pbuf)
loadImage dictRef im@(Image filename (Left (Point x y)) _ _) = do
  liftIO $ modifyMVar dictRef $ \dict -> 
    if (show im) `M.member` dict
      then do value <- deRefWeak $ dict M.! (show im)
              pbuf <- case value of
                          Just pb -> return pb 
                          Nothing -> pixbufNewFromFile filename 
              return (dict,pbuf)
      else do pbuf <- pixbufNewFromFile filename 
              wk <-  mkWeakPtr pbuf Nothing
              return ((M.insert (show im) wk dict), pbuf)