Simple Canvas Example

somesquares.hs

{-# LANGUAGE ScopedTypeVariables #-}
import Reflex.Dom
import GHCJS.DOM.CanvasRenderingContext2D (putImageData, setFillStyle, fillRect)
import GHCJS.DOM.HTMLCanvasElement (getContext)
import GHCJS.DOM.ImageData (newImageData')
import Control.Monad.IO.Class (liftIO)
import GHCJS.DOM.Types (CanvasStyle(..), CanvasRenderingContext2D(..), toJSString, castToHTMLCanvasElement)
import GHCJS.Marshal (toJSVal)
import Data.Time (getCurrentTime)

main :: IO ()
main = mainWidget putImageTest

putImageTest :: MonadWidget t m => m ()
putImageTest = do
  -- Set up a canvas
  
  -- Canvas width and height
  let w = 300
      h = 150

  -- Build an empty canvas element
  (e, _) <- el' "canvas" $ return ()

  -- Convert the canvas element from an `El` to an `HTMLCanvasElement`
  let canvasElement = castToHTMLCanvasElement (_el_element e)

  -- Get the 2D rendering context and convert it to the right type
  c <- fmap CanvasRenderingContext2D $ liftIO $ getContext canvasElement "2d"

  -- Set the fill style to red so that white images are visible when added
  liftIO $ setFillStyle c =<< (fmap (Just . CanvasStyle) $ toJSVal $ toJSString "red")
  fillRect c 0 0 w h

  -- Below, we construct a Dynamic containing the data we want to render
  -- tickLossy is, more or less, a clock event that fires on the specified interval
  t <- tickLossy 0.05 =<< liftIO getCurrentTime

  -- Every time our tickLossy event fires, we will calculate a new x and y position
  -- for our image. The `TickInfo` tickLossy produces is not used.
  let newImagePosition _ (x, y) =
        let newX = if x + 5 > w then w - x else x + 5
            newY = if y + 5 > h then h - y else y + 5
        in (newX, newY)

  -- Create a Dynamic containing the data we need to build our image
  -- For simplicity, we are only manipulating the image's position, not its
  -- contents
  imageDataDyn <- foldDyn newImagePosition (0, 0) t

  -- `addImage` builds and places an image into the canvas
  let addImage (x, y) = do
        -- Build an image with no contents (it should just be a white
        -- rectangle on our red backgound)
        i <- newImageData' 10 10
        -- Place the image
        liftIO $ putImageData c (Just i) x y

  -- Every time `imageDataDyn` is updated, add a new image to the canvas
  performEvent_ $ fmap addImage (updated imageDataDyn)

  return ()