module Graphics.Rendering.Cairo.Canvas (
Canvas, runCanvas, withRenderer, 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 qualified Graphics.Rendering.Cairo as C
import Graphics.Rendering.Cairo (Render,LineJoin(..),LineCap(..),Format(..),Operator(..))
type Byte = Word8
type Color = V4 Byte
data CanvasState = CanvasState{ csSize :: V2 Double,
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
runCanvas = flip withCairoSurface
withCairoSurface :: C.Surface -> Canvas a -> IO a
withCairoSurface s m = do
w <- fromIntegral <$> C.imageSurfaceGetWidth s
h <- fromIntegral <$> C.imageSurfaceGetHeight s
withRenderer (C.renderWith s) (V2 w h) m
withRenderer :: (forall a. Render a -> IO a)
-> V2 Double
-> Canvas a -> IO a
withRenderer renderer size c = do
let defaults = strokeWeight 1 >> strokeCap C.LineCapRound
initstate = CanvasState{ csSize = size
, csFG = Just $ gray 0
, csBG = Just $ gray 255
, csImages = []
}
(ret, result) <- renderer $ 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 = lift $ C.withTargetSurface $ \surf ->
copyFromToSurface op s sdim surf ddim
grab :: Dim -> Canvas Image
grab dim@(D _ _ w h) = do
i@(Image s _ _) <- createImage (V2 (round w) (round h))
lift $ C.withTargetSurface $ \surf ->
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