module Graphics.UI.Threepenny.Canvas (
Canvas
, Vector, Point
, Color(..), ColorStop, Gradient, FillStyle
, drawImage, clearCanvas
, solidColor, htmlColor
, linearGradient, horizontalLinearGradient, verticalLinearGradient
, fillRect, fillStyle, strokeStyle, lineWidth, textFont
, TextAlign(..), textAlign
, beginPath, moveTo, lineTo, closePath, arc, arc'
, fill, stroke, fillText, strokeText
) where
import Data.Char (toUpper)
import Data.List(intercalate)
import Numeric (showHex)
import Graphics.UI.Threepenny.Core
import qualified Data.Aeson as JSON
type Canvas = Element
type Vector = Point
type Point = (Double, Double)
data Color = RGB { red :: Int, green :: Int, blue :: Int }
| RGBA { red :: Int, green :: Int, blue :: Int, alpha :: Double }
deriving (Eq, Show)
type ColorStop = (Double, Color)
data Gradient
= LinearGradient
{ upperLeft :: Vector
, gradWidth :: Double
, gradHeight :: Double
, colorStops :: [ColorStop]
} deriving (Show, Eq)
data FillStyle
= SolidColor Color
| HtmlColor String
| Gradient Gradient
deriving (Show, Eq)
drawImage :: Element -> Vector -> Canvas -> UI ()
drawImage image (x,y) canvas =
runFunction $ ffi "%1.getContext('2d').drawImage(%2,%3,%4)" canvas image x y
solidColor :: Color -> FillStyle
solidColor rgb = SolidColor rgb
htmlColor :: String -> FillStyle
htmlColor = HtmlColor
linearGradient :: Point
-> Double
-> Double
-> [ColorStop]
-> FillStyle
linearGradient (x0, y0) w h sts = Gradient $ LinearGradient (x0,y0) w h sts
horizontalLinearGradient:: Point
-> Double
-> Color
-> Color
-> FillStyle
horizontalLinearGradient pt w c0 c1 = linearGradient pt w 0 [(0, c0), (1, c1)]
verticalLinearGradient:: Point
-> Double
-> Color
-> Color
-> FillStyle
verticalLinearGradient pt h c0 c1 = linearGradient pt 0 h [(0, c0), (1, c1)]
clearCanvas :: Canvas -> UI ()
clearCanvas = runFunction . ffi "%1.getContext('2d').clear()"
fillRect
:: Point
-> Double
-> Double
-> Canvas -> UI ()
fillRect (x,y) w h canvas =
runFunction $ ffi "%1.getContext('2d').fillRect(%2, %3, %4, %5)" canvas x y w h
fillStyle :: WriteAttr Canvas FillStyle
fillStyle = mkWriteAttr assignFillStyle
assignFillStyle :: FillStyle -> Canvas -> UI ()
assignFillStyle (Gradient fs) canvas =
runFunction $ ffi cmd canvas
where cmd = "var ctx=%1.getContext('2d'); var grd=" ++ fsStr fs ++ cStops fs ++ "ctx.fillStyle=grd;"
fsStr (LinearGradient (x0, y0) w h _)
= "ctx.createLinearGradient(" ++ pStr [x0, y0, x0+w, y0+h] ++ ");"
cStops (LinearGradient _ _ _ sts) = concatMap addStop sts
addStop (p,c) = "grd.addColorStop(" ++ show p ++ ",'" ++ rgbString c ++ "');"
pStr = intercalate "," . map show
assignFillStyle (SolidColor color) canvas =
runFunction $ ffi "%1.getContext('2d').fillStyle=%2" canvas (rgbString color)
assignFillStyle (HtmlColor color) canvas =
runFunction $ ffi "%1.getContext('2d').fillStyle=%2" canvas color
strokeStyle :: Attr Canvas String
strokeStyle = fromObjectProperty "getContext('2d').strokeStyle"
lineWidth :: Attr Canvas Double
lineWidth = fromObjectProperty "getContext('2d').lineWidth"
textFont :: Attr Canvas String
textFont = fromObjectProperty "getContext('2d').font"
data TextAlign = Start | End | LeftAligned | RightAligned | Center
deriving (Eq, Show, Read)
aToS :: TextAlign -> String
aToS algn =
case algn of
Start -> "start"
End -> "end"
LeftAligned -> "left"
RightAligned -> "right"
Center -> "center"
sToA :: String -> TextAlign
sToA algn =
case algn of
"start" -> Start
"end" -> End
"left" -> LeftAligned
"right" -> RightAligned
"center" -> Center
_ -> Start
textAlign :: Attr Canvas TextAlign
textAlign = bimapAttr aToS sToA $ textAlignStr
where
textAlignStr :: Attr Canvas String
textAlignStr = fromObjectProperty "getContext('2d').textAlign"
beginPath :: Canvas -> UI()
beginPath = runFunction . ffi "%1.getContext('2d').beginPath()"
moveTo :: Point -> Canvas -> UI()
moveTo (x,y) canvas =
runFunction $ ffi "%1.getContext('2d').moveTo(%2, %3)" canvas x y
lineTo :: Point -> Canvas -> UI()
lineTo (x,y) canvas =
runFunction $ ffi "%1.getContext('2d').lineTo(%2, %3)" canvas x y
closePath :: Canvas -> UI()
closePath = runFunction . ffi "%1.getContext('2d').closePath()"
arc
:: Point
-> Double
-> Double
-> Double
-> Canvas -> UI ()
arc (x,y) radius startAngle endAngle canvas =
runFunction $ ffi "%1.getContext('2d').arc(%2, %3, %4, %5, %6)"
canvas x y radius startAngle endAngle
arc' :: Point -> Double -> Double -> Double -> Bool -> Canvas -> UI ()
arc' (x,y) radius startAngle endAngle anti canvas =
runFunction $ ffi "%1.getContext('2d').arc(%2, %3, %4, %5, %6, %7)"
canvas x y radius startAngle endAngle anti
fill :: Canvas -> UI ()
fill = runFunction . ffi "%1.getContext('2d').fill()"
stroke :: Canvas -> UI ()
stroke = runFunction . ffi "%1.getContext('2d').stroke()"
fillText :: String -> Point -> Canvas -> UI ()
fillText text (x,y) canvas =
runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas text x y
strokeText :: String -> Point -> Canvas -> UI ()
strokeText text (x,y) canvas =
runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas text x y
rgbString :: Color -> String
rgbString color =
case color of
(RGB r g b) -> "#" ++ sh r ++ sh g ++ sh b
(RGBA r g b a) -> "rgba(" ++ show r ++ "," ++ show g ++ "," ++ show b ++ "," ++ show a ++ ")"
where sh i = pad . map toUpper $ showHex i ""
pad s
| length s == 0 = "00"
| length s == 1 = '0' : s
| length s == 2 = s
| otherwise = take 2 s