Canvas.hs

import Control.Monad

import Paths

import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core


{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main :: IO ()
main = do
    static <- getStaticDir
    startGUI defaultConfig setup

canvasSize = 400

setup :: Window -> UI ()
setup window = do
    return window # set title "Canvas - Examples"

    canvas <- UI.canvas
        # set UI.height canvasSize
        # set UI.width  canvasSize
        # set style [("border", "solid black 1px"), ("background", "#eee")]

    drawRects <- UI.button #+ [string "Add some rectangles."]
    drawText  <- UI.button #+ [string "Add text."]
    drawImage <- UI.button #+ [string "Add image."]
    drawPie   <- UI.button #+ [string "Must have pie!"]
    clear     <- UI.button #+ [string "Clear the canvas."]

    getBody window #+
        [ column [element canvas]
        , element drawRects, element drawText, element drawImage
        , element drawPie  , element clear
        ]

    on UI.click clear $ const $
        canvas # UI.clearCanvas

    -- draw a pie chart
    on UI.click drawPie $ const $ do
        let
            center = (fromIntegral canvasSize / 2, fromIntegral (canvasSize+30) / 2)
            radius = 100

            drawSlice start end color = do
                canvas # set' UI.fillStyle (UI.htmlColor color)
                canvas # set' UI.strokeStyle "white"
                canvas # UI.beginPath
                canvas # UI.arc center radius start end
                canvas # UI.lineTo center
                canvas # UI.closePath
                canvas # UI.fill
                canvas # UI.stroke

            radian angle = angle * pi / 180

            normalizeAngles xs = map (\(x,y) -> (360 * x/total,y)) xs
                where total = sum $ map fst xs

            pieData = normalizeAngles
                [ (100, "#1f77b4")
                , (45, "#ff7f0e")
                , (80, "#2ca02c")
                , (10, "#d62728")
                , (105,"#9467bd")
                , (20, "#8c564b")
                ]

        UI.timestamp -- measure drawing performance for fun
        foldM (\start (delta, col) -> do
            let end = start+delta
            drawSlice (radian start) (radian end) col
            return end) 0 pieData
        UI.timestamp


    -- draw some rectangles
    on UI.click drawRects $ const $ do
        let rects = [ (20 , 130, 15, 120, "teal")
                    , (345, 110, 15, 90, "lightblue")
                    , (220, 360, 95, 15, "teal")
                    ]

        forM_ rects $ \(x,y,w,h,color) -> do
            canvas # set' UI.fillStyle (UI.htmlColor color)
            canvas # UI.fillRect (x,y) w h

    -- draw some text
    on UI.click drawText $ const $ do
        return canvas
            # set UI.textFont    "30px sans-serif"
            # set UI.strokeStyle "gray"
            # set UI.fillStyle   (UI.htmlColor "black")

        canvas # UI.strokeText "is awesome" (141,61)
        canvas # UI.fillText   "is awesome" (140,60)

    -- draw the haskell logo
    url <- UI.loadFile "image/png" "static/haskell-logo.png"
    img <- UI.img # set UI.src url

    on UI.click drawImage $ const $ do
        canvas # UI.drawImage img (60,20)