module Graphics.Shine.Render (
render
) where
import GHCJS.DOM.HTMLImageElement (getWidth, getHeight)
import GHCJS.DOM.CanvasRenderingContext2D
import GHCJS.DOM.CanvasPath
import GHCJS.DOM.Enums (CanvasWindingRule (CanvasWindingRuleNonzero))
import GHCJS.DOM.Types (JSM, CanvasStyle (..))
import GHCJS.Prim (toJSString)
import Data.List (intercalate)
import Graphics.Shine.Picture
import Graphics.Shine.Image
render :: CanvasRenderingContext2D -> Picture -> JSM ()
render _ Empty = return ()
render ctx (Line x y x' y') = do
moveTo ctx x y
lineTo ctx x' y'
stroke ctx
render ctx (Rect x y) = do
rect ctx (x/2) (y/2) x y
stroke ctx
render ctx (RectF x' y') = fillRect ctx (x/2) (y/2) x y
where x = realToFrac x'
y = realToFrac y'
render ctx (Polygon ((x,y):pts)) = do
beginPath ctx
moveTo ctx x y
mapM_ (uncurry (lineTo ctx)) pts
closePath ctx
fill ctx $ Just CanvasWindingRuleNonzero
render ctx (Polygon []) = render ctx Empty
render ctx (Arc r a b direction) = do
beginPath ctx
arc ctx 0 0 r a b direction
stroke ctx
render ctx (CircleF r') = do
save ctx
render ctx $ circle r
clip ctx $ Just CanvasWindingRuleNonzero
render ctx $ RectF (r*2) (r*2)
restore ctx
where r = realToFrac r'
render ctx (Text font align width' txt) = do
setFont ctx font
setTextAlign ctx $ case align of LeftAlign -> "left"
CenterAlign -> "center"
RightAlign -> "rignt"
fillText ctx txt 0 0 width
where width = realToFrac <$> width'
render ctx (Image size (ImageData img)) =
case size of
Original -> do
x <- ((/(2)) . realToFrac) <$> getWidth img
y <- ((/(2)) . realToFrac) <$> getHeight img
drawImage ctx img x y
(Stretched w h) -> do
let (x, y) = (w/2, h/2)
drawImageScaled ctx img x y w h
(Clipped a b c d) -> do
let (x, y) = (c/2, d/2)
drawImagePart ctx img a b c d x y c d
(ClippedStretched a b c d e f) -> do
let (x, y) = (e/2, f/2)
drawImagePart ctx img a b c d x y e f
render ctx (Over a b) = do
render ctx a
render ctx b
render ctx (Colored col (Over a b)) = render ctx $ Over (Colored col a)
(Colored col b)
render ctx (Colored col (Rotate angle pic)) =
render ctx $ Rotate angle $ Colored col pic
render ctx (Colored col (Translate x y pic)) =
render ctx $ Translate x y $ Colored col pic
render ctx (Colored _ (Colored col pic)) =
render ctx $ Colored col pic
render ctx (Colored (Color r g b a) pic) = do
let colorString = "rgba("
++ intercalate "," [show r, show g, show b, show a]
++ ")"
let color = toJSString colorString
setFillStyle ctx $ CanvasStyle color
setStrokeStyle ctx $ CanvasStyle color
render ctx pic
let black = toJSString "#000000"
setFillStyle ctx $ CanvasStyle black
setStrokeStyle ctx $ CanvasStyle black
render ctx (Rotate angle' pic) = do
rotate ctx angle
render ctx pic
rotate ctx (angle)
where angle = realToFrac angle'
render ctx (Translate x' y' pic) = do
translate ctx x y
render ctx pic
translate ctx (x) (y)
where x = realToFrac x'
y = realToFrac y'