module SDL.Cairo.Canvas (
Canvas, withCanvas, getCanvasSize,
Color, Byte, gray, red, green, blue, rgb, (!@),
stroke, fill, noStroke, noFill, strokeWeight, strokeJoin, strokeCap,
Dim(..), toD, dimPos, dimSize, Anchor(..), aligned, 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, textExtents, text, text',
mapRange, radians, degrees,
randomSeed, random, getTime, Time(..),
LineCap(..), LineJoin(..)
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
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 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,
csImages :: [Image]
}
getCanvasSize :: Canvas (V2 Double)
getCanvasSize = gets csSize
newtype RenderWrapper m a = Canvas { unCanvas :: StateT CanvasState m a }
deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadState CanvasState)
type Canvas = RenderWrapper Render
withCanvas :: Texture -> Canvas a -> IO a
withCanvas t c = withCairoTexture' t $ \s -> do
(TextureInfo _ _ w h) <- queryTexture t
let defaults = strokeWeight 1 >> strokeCap C.LineCapRound
initstate = CanvasState{ csSize = V2 (fromIntegral w) (fromIntegral h)
, csSurface = s
, csFG = Just $ gray 0
, csBG = Just $ gray 255
, csImages = []
}
(ret, result) <- C.renderWith s $ runStateT (unCanvas $ defaults >> c) initstate
forM_ (csImages result) $ \(Image s _ _) -> C.surfaceFinish s
return ret
stroke :: Color -> Canvas ()
stroke clr = modify $ \cs -> cs{csFG=Just clr}
fill :: Color -> Canvas ()
fill clr = modify $ \cs -> cs{csBG=Just clr}
noStroke :: Canvas ()
noStroke = modify $ \cs -> cs{csFG=Nothing}
noFill :: Canvas ()
noFill = modify $ \cs -> 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 = lift $ C.setLineWidth d
strokeJoin :: C.LineJoin -> Canvas ()
strokeJoin l = lift $ C.setLineJoin l
strokeCap :: C.LineCap -> Canvas ()
strokeCap l = lift $ C.setLineCap l
data Dim = D Double Double Double Double deriving (Show,Eq)
data Anchor = NW | N | NE | E | SE | S | SW | W | Center | Baseline deriving (Show,Eq)
toD (V2 a b) (V2 c d) = D a b c d
dimPos (D a b _ _) = V2 a b
dimSize (D _ _ c d) = V2 c d
corners (D xl yl xh yh) = D xl yl (xhxl) (yhyl)
centered = aligned Center
aligned :: Anchor -> Dim -> Dim
aligned NW dim = dim
aligned NE (D x y w h) = D (xw) y w h
aligned SW (D x y w h) = D x (yh) w h
aligned SE (D x y w h) = D (xw) (yh) w h
aligned Baseline dim = aligned SW dim
aligned N (D x y w h) = D (xw/2) y w h
aligned W (D x y w h) = D x (yh/2) w h
aligned S (D x y w h) = D (xw/2) (yh) w h
aligned E (D x y w h) = D (xw) (yh/2) w h
aligned Center (D x y w h) = D (xw/2) (yh/2) w h
resetMatrix :: Canvas ()
resetMatrix = lift C.identityMatrix
pushMatrix :: Canvas ()
pushMatrix = lift C.save
popMatrix :: Canvas ()
popMatrix = lift C.restore
translate :: V2 Double -> Canvas ()
translate (V2 x y) = lift $ C.translate x y
scale :: V2 Double -> Canvas ()
scale (V2 x y) = lift $ C.scale x y
rotate :: Double -> Canvas ()
rotate a = lift $ C.rotate a
background :: Color -> Canvas ()
background c = do
(V2 w h) <- gets csSize
lift $ 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 (ShapeRegular _) _ = return ()
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+(w/2)) (y+(h/2))
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 = 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 _ (V2 ow oh) _) =
blend OperatorSource img (D 0 0 (fromIntegral ow) (fromIntegral oh))
blend :: Operator -> Image -> Dim -> Dim -> Canvas ()
blend op (Image s _ _) sdim ddim = do
surf <- gets csSurface
lift $ copyFromToSurface op s sdim surf ddim
grab :: Dim -> Canvas Image
grab dim@(D _ _ w h) = do
surf <- gets csSurface
i@(Image s _ _) <- createImage (V2 (round w) (round h))
lift $ 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 = lift $ setFont f
textSize :: String -> Canvas (V2 Double)
textSize = return . dimSize . fst <=< textExtents
textExtents :: String -> Canvas (Dim, V2 Double)
textExtents s = do
(C.TextExtents xb yb w h xa ya) <- lift $ C.textExtents s
return ((D xb yb w h),(V2 xa ya))
text :: String -> V2 Double -> Canvas (V2 Double)
text = text' Baseline
text' :: Anchor -> String -> V2 Double -> Canvas (V2 Double)
text' a str pos = do
(C.TextExtents xb yb w h xa ya) <- lift $ C.textExtents str
let (D xn yn _ _) = (if a==Baseline then id else aligned a) $ toD pos $ V2 w h
(V2 x' y') = (V2 xn yn) if a/=Baseline then (V2 xb yb) else 0
ifColor csFG $ \c -> C.moveTo x' y' >> setColor c >> C.showText str
return $ V2 xa ya
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 a) -> Canvas ()
ifColor cf m = get >>= \cs -> case cf cs of
Just c -> lift (m c) >> return ()
Nothing -> return ()
setColor :: Color -> Render ()
setColor (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 = modify $ \cs -> 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
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/=ow || 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