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)
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
cg :: String -> Paper -> [P.Image] -> IO ()
cg fn (Paper w h) pp = cg' fn (Paper w h) (map (i_xflip h) pp)