module SDL.Cairo.Canvas (
Canvas, withCanvas, getCanvasSize, renderCairo,
Color, Byte, gray, red, green, blue, rgb, (!@),
stroke, fill, noStroke, noFill, strokeWeight, strokeJoin, strokeCap,
Dim(..), toD, centered, corners,
background, point, line, triangle, rect, polygon, shape, ShapeMode(..),
circle, circle', arc, ellipse, bezier, bezierQ,
resetMatrix, pushMatrix, popMatrix, translate, rotate, scale,
Image(imageSize), createImage, loadImagePNG, saveImagePNG, image, image', blend, grab,
Font(..), textFont, textSize, text, textC, textR,
mapRange, radians, degrees,
randomSeed, random, getTime, Time(..),
module Graphics.Rendering.Cairo
) where
import Data.Monoid
import Control.Monad.State
import Data.Word (Word8)
import Data.Time.Clock (UTCTime(..),getCurrentTime)
import Data.Time.LocalTime (timeToTimeOfDay,TimeOfDay(..))
import Data.Time.Calendar (toGregorian)
import System.Random (mkStdGen,setStdGen,randomRIO,Random)
import Linear.V2 (V2(..))
import Linear.V4 (V4(..))
import Linear.Affine (Point(..))
import SDL (Texture,TextureInfo(..),queryTexture)
import qualified Graphics.Rendering.Cairo as C
import Graphics.Rendering.Cairo (Render,LineJoin(..),LineCap(..),Format(..),Operator(..))
import SDL.Cairo (withCairoTexture')
type Byte = Word8
type Color = V4 Byte
data CanvasState = CanvasState{ csSize :: V2 Double,
csSurface :: C.Surface,
csFG :: Maybe Color,
csBG :: Maybe Color,
csFont :: Font,
csActions :: Endo [Render ()],
csImages :: [Image]
}
getCanvasSize :: Canvas (V2 Double)
getCanvasSize = gets csSize
newtype Canvas a = Canvas { unCanvas :: StateT CanvasState IO a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState CanvasState)
withCanvas :: Texture -> Canvas a -> IO a
withCanvas t c = withCairoTexture' t $ \s -> do
(TextureInfo _ _ w h) <- queryTexture t
(ret, result) <- runStateT (unCanvas $ defaults >> c)
CanvasState{ csSize = V2 (fromIntegral w) (fromIntegral h)
, csSurface = s
, csFG = Just $ gray 0
, csBG = Just $ gray 255
, csFont = Font "" 10 False False
, csActions = mempty
, csImages = []
}
let render = appEndo (csActions result) []
C.renderWith s $ sequence_ render
forM_ (csImages result) $ \(Image s _ _) -> C.surfaceFinish s
return ret
where defaults = do
strokeWeight 1
strokeCap C.LineCapRound
stroke :: Color -> Canvas ()
stroke clr = get >>= \cs -> put cs{csFG=Just clr}
fill :: Color -> Canvas ()
fill clr = get >>= \cs -> put cs{csBG=Just clr}
noStroke :: Canvas ()
noStroke = get >>= \cs -> put cs{csFG=Nothing}
noFill :: Canvas ()
noFill = get >>= \cs -> put cs{csBG=Nothing}
gray :: Byte -> Color
gray c = V4 c c c 255
red :: Byte -> Color
red c = V4 c 0 0 255
green :: Byte -> Color
green c = V4 0 c 0 255
blue :: Byte -> Color
blue c = V4 0 0 c 255
rgb :: Byte -> Byte -> Byte -> Color
rgb r g b = V4 r g b 255
(!@) :: Color -> Byte -> Color
(V4 r g b _) !@ a = V4 r g b a
strokeWeight :: Double -> Canvas ()
strokeWeight d = renderCairo $ C.setLineWidth d
strokeJoin :: C.LineJoin -> Canvas ()
strokeJoin l = renderCairo $ C.setLineJoin l
strokeCap :: C.LineCap -> Canvas ()
strokeCap l = renderCairo $ C.setLineCap l
data Dim = D Double Double Double Double deriving (Show,Eq)
toD (V2 a b) (V2 c d) = D a b c d
centered (D cx cy w h) = D (cxw/2) (cyh/2) w h
corners (D xl yl xh yh) = D xl yl (xhxl) (yhyl)
resetMatrix :: Canvas ()
resetMatrix = renderCairo $ C.identityMatrix
pushMatrix :: Canvas ()
pushMatrix = renderCairo $ C.save
popMatrix :: Canvas ()
popMatrix = renderCairo $ C.restore
translate :: V2 Double -> Canvas ()
translate (V2 x y) = renderCairo $ C.translate x y
scale :: V2 Double -> Canvas ()
scale (V2 x y) = renderCairo $ C.scale x y
rotate :: Double -> Canvas ()
rotate a = renderCairo $ C.rotate a
background :: Color -> Canvas ()
background c = do
(V2 w h) <- gets csSize
renderCairo $ setColor c >> C.rectangle 0 0 w h >> C.fill
point :: V2 Double -> Canvas ()
point (V2 x y) = ifColor csFG $ \c -> do
C.rectangle x y 1 1
setColor c
C.fill
line :: V2 Double -> V2 Double -> Canvas ()
line (V2 x1 y1) (V2 x2 y2) = ifColor csFG $ \c -> do
C.moveTo x1 y1
C.lineTo x2 y2
setColor c
C.stroke
triangle :: V2 Double -> V2 Double -> V2 Double -> Canvas ()
triangle (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) = drawShape $ do
C.moveTo x1 y1
C.lineTo x2 y2
C.lineTo x3 y3
C.lineTo x1 y1
rect :: Dim -> Canvas ()
rect (D x y w h) = drawShape $ C.rectangle x y w h
polygon :: [V2 Double] -> Canvas ()
polygon = shape (ShapeRegular True)
data ShapeMode = ShapeRegular Bool
| ShapePoints
| ShapeLines
| ShapeTriangles
| ShapeTriangleStrip
| ShapeTriangleFan
deriving (Show,Eq)
shape :: ShapeMode -> [V2 Double] -> Canvas ()
shape (ShapeRegular closed) ((V2 x y):ps) = drawShape $ do
C.moveTo x y
forM_ ps $ \(V2 x' y') -> C.lineTo x' y'
when closed $ C.closePath
shape ShapePoints ps = forM_ ps point
shape ShapeLines (p1:p2:ps) = do
line p1 p2
shape ShapeLines ps
shape ShapeLines _ = return ()
shape ShapeTriangles (p1:p2:p3:ps) = do
triangle p1 p2 p3
shape ShapeTriangles ps
shape ShapeTriangles _ = return ()
shape ShapeTriangleStrip (p1:p2:p3:ps) = do
triangle p1 p2 p3
shape ShapeTriangleStrip (p2:p3:ps)
shape ShapeTriangleStrip _ = return ()
shape ShapeTriangleFan (p1:p2:p3:ps) = do
triangle p1 p2 p3
shape ShapeTriangleFan (p1:p3:ps)
shape ShapeTriangleFan _ = return ()
arc :: Dim -> Double -> Double -> Canvas ()
arc (D x y w h) sa ea = drawShape $ do
C.save
C.translate x y
C.scale (w/2) (h/2)
C.arc 0 0 1 sa ea
C.restore
ellipse :: Dim -> Canvas ()
ellipse dim = arc dim 0 (2*pi)
circle :: V2 Double -> Double -> Canvas ()
circle (V2 x y) d = ellipse (D x y d d)
circle' :: V2 Double -> Double -> Canvas ()
circle' (V2 x y) d = ellipse $ centered (D x y d d)
bezier :: V2 Double -> V2 Double -> V2 Double -> V2 Double -> Canvas ()
bezier (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) = drawShape $ do
C.moveTo x1 y1
C.curveTo x2 y2 x3 y3 x4 y4
bezierQ :: V2 Double -> V2 Double -> V2 Double -> Canvas ()
bezierQ p0 p12 p3 = bezier p0 p1 p2 p3
where p1 = p0 + 2/3*(p12p0)
p2 = p3 + 2/3*(p12p3)
mapRange :: Double -> (Double,Double) -> (Double,Double) -> Double
mapRange v (l1,r1) (l2,r2) = (vl1)*fac + l2
where fac = (r2l2)/(r1l1)
radians :: Double -> Double
radians d = d*pi/180
degrees :: Double -> Double
degrees r = r/pi*180
constrain :: Double -> (Double,Double) -> Double
constrain v (l,h) = max l $ min h v
randomSeed :: Int -> Canvas ()
randomSeed s = liftIO $ setStdGen $ mkStdGen s
random :: (Random a) => (a,a) -> Canvas a
random = liftIO . randomRIO
data Time = Time { year :: Int, month :: Int, day :: Int
, hour :: Int, minute :: Int, second :: Int } deriving (Show,Eq)
getTime :: IO Time
getTime = do
(UTCTime day time) <- getCurrentTime
let (y,m,d) = toGregorian day
(TimeOfDay h mins s) = timeToTimeOfDay time
return $ Time (fromIntegral y::Int) m d h mins (round s :: Int)
data Image = Image {imageSurface::C.Surface, imageSize::(V2 Int), imageFormat::Format}
createImage :: V2 Int -> Canvas Image
createImage (V2 w h) = do
s <- liftIO $ C.createImageSurface FormatARGB32 w h
let img = Image s (V2 w h) FormatARGB32
track img
return img
loadImagePNG :: FilePath -> Canvas Image
loadImagePNG path = do
s <- liftIO $ C.imageSurfaceCreateFromPNG path
w <- C.imageSurfaceGetWidth s
h <- C.imageSurfaceGetHeight s
f <- C.imageSurfaceGetFormat s
let img = Image s (V2 w h) f
track img
return img
saveImagePNG :: Image -> FilePath -> Canvas ()
saveImagePNG (Image s _ _) fp = renderCairo $ liftIO (C.surfaceWriteToPNG s fp)
image :: Image -> V2 Double -> Canvas ()
image img@(Image _ (V2 w h) _) (V2 x y) =
image' img (D x y (fromIntegral w) (fromIntegral h))
image' :: Image -> Dim -> Canvas ()
image' img@(Image s (V2 ow oh) _) =
blend OperatorSource img (D 0 0 (fromIntegral ow) (fromIntegral oh))
blend :: Operator -> Image -> Dim -> Dim -> Canvas ()
blend op (Image s (V2 ow oh) _) sdim ddim = do
surf <- gets csSurface
renderCairo $ copyFromToSurface op s sdim surf ddim
grab :: Dim -> Canvas Image
grab dim@(D x y w h) = do
surf <- gets csSurface
i@(Image s _ _) <- createImage (V2 (round w) (round h))
renderCairo $ copyFromToSurface OperatorSource surf dim s (D 0 0 w h)
return i
data Font = Font{fontFace::String
,fontSize::Double
,fontBold::Bool
,fontItalic::Bool} deriving (Show,Eq)
textFont :: Font -> Canvas ()
textFont f = do
get >>= \cs -> put cs{csFont=f}
renderCairo $ setFont f
textSize :: String -> Canvas (V2 Double)
textSize s = gets csSurface >>= \cs -> do
font <- gets csFont
(C.TextExtents _ _ w h _ _) <- C.renderWith cs $ setFont font >> C.textExtents s
return $ V2 w h
text :: String -> V2 Double -> Canvas ()
text str (V2 x y) = ifColor csFG $ \c -> do
(C.TextExtents _ yb _ h _ _) <- C.textExtents str
setColor c
C.moveTo x (yyb)
C.showText str
textR :: String -> V2 Double -> Canvas ()
textR str (V2 x y) = do
(V2 w h) <- textSize str
text str $ V2 (xw) y
textC :: String -> V2 Double -> Canvas ()
textC str (V2 x y) = do
(V2 w h) <- textSize str
text str $ V2 (x(w/2)) (y(h/2))
renderCairo :: Render () -> Canvas ()
renderCairo m = get >>= \cs -> put cs{csActions = csActions cs <> Endo ([m]++)}
drawShape :: Render a -> Canvas ()
drawShape m = do
ifColor csBG $ \c -> m >> setColor c >> C.fill
ifColor csFG $ \c -> m >> setColor c >> C.stroke
ifColor :: (CanvasState -> Maybe Color) -> (Color -> Render ()) -> Canvas ()
ifColor cf m = get >>= \cs -> forM_ (cf cs) $ \c -> renderCairo (m c)
setColor :: Color -> Render ()
setColor c@(V4 r g b a) = C.setSourceRGBA (conv r) (conv g) (conv b) (conv a)
where conv = ((1.0/256)*).fromIntegral
track :: Image -> Canvas ()
track img = get >>= \cs -> put cs{csImages=img:csImages cs}
createScaledSurface :: C.Surface -> (V2 Double) -> Render C.Surface
createScaledSurface s (V2 w h) = do
ow <- C.imageSurfaceGetWidth s
oh <- C.imageSurfaceGetHeight s
s' <- liftIO $ C.createSimilarSurface s C.ContentColorAlpha (round w) (round h)
C.renderWith s' $ do
C.scale (w/fromIntegral ow) (h/fromIntegral oh)
C.setSourceSurface s 0 0
pat <- C.getSource
C.patternSetExtend pat C.ExtendPad
C.setOperator C.OperatorSource
C.paint
return s'
createTrimmedSurface :: C.Surface -> Dim -> Render C.Surface
createTrimmedSurface s (D x y w h) = do
ow <- C.imageSurfaceGetWidth s
oh <- C.imageSurfaceGetHeight s
s' <- liftIO $ C.createSimilarSurface s C.ContentColorAlpha (round w) (round h)
C.renderWith s' $ do
C.setSourceSurface s (x) (y)
C.setOperator C.OperatorSource
C.rectangle 0 0 w h
C.fill
return s'
copyFromToSurface :: Operator -> C.Surface -> Dim -> C.Surface -> Dim -> Render ()
copyFromToSurface op src sdim@(D sx sy sw sh) dest (D x y w h) = do
ow <- C.imageSurfaceGetWidth src
oh <- C.imageSurfaceGetHeight src
let needsTrim = sx/=0 || sy/=0 || round sw/=oh || round sh/=oh
needsRescale = round sw/=round w || round sh/=round h
s' <- if needsTrim then createTrimmedSurface src sdim else return src
s'' <- if needsRescale then createScaledSurface s' (V2 w h) else return s'
C.renderWith dest $ do
C.save
C.setSourceSurface s'' x y
C.setOperator op
C.rectangle x y w h
C.fill
C.restore
when needsTrim $ C.surfaceFinish s'
when needsRescale $ C.surfaceFinish s''
setFont :: Font -> Render ()
setFont (Font face sz bold italic) = do
C.selectFontFace face
(if italic then C.FontSlantItalic else C.FontSlantNormal)
(if bold then C.FontWeightBold else C.FontWeightNormal)
C.setFontSize sz