fay-0.24.2.0: examples/CodeWorld.hs

{-
    (By Chris Smith)
    Reimplementation of gloss (minus bitmaps) in terms of Fay.  This is a proof
    of concept that Fay is in a state where it can support use cases like
    gloss-web on the client.

    TODO:
    - Fix the problem with unary negation
    - Implement support for events and game mode

    To try it out, skip the boilerplate section at the top; in the final
    implementation, it will eventually be moved to a different module and
    imported.  Change the definition of go to one of drawIt, animateIt, or
    simulateIt to try the various modes.
-}

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE EmptyDataDecls    #-}

module CodeWorld where

import Prelude
import FFI


data Element

getElementById :: String -> Fay Element
getElementById = ffi "document['getElementById'](%1)"

focusElement :: Element -> Fay ()
focusElement = ffi "%1.focus()"

data Event

addEventListener :: String -> Bool -> (Event -> Fay Bool) -> Fay ()
addEventListener = ffi "window['addEventListener'](%1,%3,%2)"

--getEventKeyCode :: Event -> Fay String
--getEventKeyCode = ffi "%1['keyCode']"

getEventMouseButton :: Event -> Fay Int
getEventMouseButton = ffi "%1['button']"

data Timer

setInterval :: Double -> Fay () -> Fay Timer
setInterval = ffi "window['setInterval'](%2,%1)"

data Ref a

newRef :: a -> Fay (Ref a)
newRef = ffi "new Fay$$Ref(%1)"

writeRef :: Ref a -> a -> Fay ()
writeRef = ffi "Fay$$writeRef(%1,%2)"

readRef :: Ref a -> Fay a
readRef = ffi "Fay$$readRef(%1)"

currentTimeMillis :: Fay Double
currentTimeMillis = ffi "(Date.now?Date.now():new Date().getTime())"

data Context

getContext :: Element -> String -> Fay Context
getContext = ffi "%1['getContext'](%2)"

clearRect :: Context -> Double -> Double -> Double -> Double -> Fay ()
clearRect = ffi "%1['clearRect'](%2,%3,%4,%5)"

save :: Context -> Fay ()
save = ffi "%1['save']()"

restore :: Context -> Fay ()
restore = ffi "%1['restore']()"

canvasTranslate :: Context -> Double -> Double -> Fay ()
canvasTranslate = ffi "%1['translate'](%2,%3)"

canvasScale :: Context -> Double -> Double -> Fay ()
canvasScale = ffi "%1['scale'](%2,%3)"

transform :: Context
          -> Double -> Double -> Double -> Double -> Double -> Double
          -> Fay ()
transform = ffi "%1['transform'](%2,%3,%4,%5,%6,%7)"

setTextAlign :: Context -> String -> Fay ()
setTextAlign = ffi "%1['textAlign']=%2"

setTextBaseline :: Context -> String -> Fay ()
setTextBaseline = ffi "%1['textBaseline']=%2"

setLineWidth :: Context -> Double -> Fay ()
setLineWidth = ffi "%1['lineWidth']=%2"

setFont :: Context -> String -> Fay ()
setFont = ffi "%1['font']=%2"

setStrokeStyle :: Context -> String -> Fay ()
setStrokeStyle = ffi "%1['strokeStyle']=%2"

setFillStyle :: Context -> String -> Fay ()
setFillStyle = ffi "%1['fillStyle']=%2"

beginPath :: Context -> Fay ()
beginPath = ffi "%1['beginPath']()"

closePath :: Context -> Fay ()
closePath = ffi "%1['closePath']()"

fill :: Context -> Fay ()
fill = ffi "%1['fill']()"

stroke :: Context -> Fay ()
stroke = ffi "%1['stroke']()"

fillText :: Context ->String -> Double -> Double -> Fay ()
fillText = ffi "%1['fillText'](%2,%3,%4)"

moveTo :: Context -> Double -> Double -> Fay ()
moveTo = ffi "%1['moveTo'](%2,%3)"

lineTo :: Context -> Double -> Double -> Fay ()
lineTo = ffi "%1['lineTo'](%2,%3)"

canvasArc :: Context -> Double -> Double -> Double -> Double -> Double -> Bool -> Fay ()
canvasArc = ffi "%1['arc'](%2,%3,%4,%5,%6,%7)"

-- Special functions defined in codeworld.js

getSpecialKey :: Event -> Fay String
getSpecialKey = ffi "window.getSpecialKey(%1)"

getPressedKey :: Event -> Fay String
getPressedKey = ffi "window.getPressedKey(%1)"

getReleasedKey :: Event -> Fay String
getReleasedKey = ffi "window.getReleasedKey(%1)"

stopEvent :: Event -> Fay ()
stopEvent = ffi "window.stopEvent(%1)"

mouseToElementX :: Event -> Fay Double
mouseToElementX = ffi "window.mouseToElementX(%1)"

mouseToElementY :: Event -> Fay Double
mouseToElementY = ffi "window.mouseToElementY(%1)"

type Transform = (Double, Double, Double, Double, Double, Double)

translateTransform :: Double -> Double -> Transform -> Transform
translateTransform x y (a,b,c,d,e,f) =
    (a, b, c, d, a * x + c * y + e, b * x + d * y + f)

scaleTransform :: Double -> Double -> Transform -> Transform
scaleTransform x y (a,b,c,d,e,f) =
    (x*a, x*b, y*c, y*d, e, f)

rotateTransform :: Double -> Transform -> Transform
rotateTransform r (a,b,c,d,e,f) = let th = r * pi / 180 in
    (a * cos th + c * sin th,
     b * cos th + d * sin th,
     c * cos th - a * sin th,
     d * cos th - b * sin th,
     e, f)

withTransform :: Context -> Transform -> Fay () -> Fay ()
withTransform ctx (a,b,c,d,e,f) action = do
    save ctx
    transform ctx a b c d e f
    beginPath ctx
    action
    restore ctx

data Color = RGBA Double Double Double Double

white, black :: Color
white = RGBA 1 1 1 1
black = RGBA 0 0 0 1

red, green, blue, cyan, magenta, yellow :: Color
red        = RGBA 1 0 0 1
green      = RGBA 0 1 0 1
blue       = RGBA 0 0 1 1
yellow     = RGBA 1 1 0 1
cyan       = RGBA 0 1 1 1
magenta    = RGBA 1 0 1 1

orange, rose, chartreuse, aquamarine, violet, azure :: Color
orange     = RGBA 1.0 0.5 0.0 1
rose       = RGBA 1.0 0.0 0.5 1
chartreuse = RGBA 0.5 1.0 0.0 1
aquamarine = RGBA 0.0 1.0 0.5 1
violet     = RGBA 0.5 0.0 1.0 1
azure      = RGBA 0.0 0.5 1.0 1

light :: Color -> Color
light (RGBA r g b a) = RGBA
    (min 1 (r + 0.2))
    (min 1 (g + 0.2))
    (min 1 (b + 0.2))
    a

dark :: Color -> Color
dark (RGBA r g b a) = RGBA
    (max 0 (r - 0.2))
    (max 0 (g - 0.2))
    (max 0 (b - 0.2))
    a

gray, grey :: Double -> Color
gray = grey
grey k = RGBA k k k 1

type Point = (Double, Double)
type Vector = Point

data Picture = Polygon [Point]
             | Line [Point]
             | ThickArc Double Double Double Double
             | Text String
             | Color Color Picture
             | Translate Double Double Picture
             | Scale Double Double Picture
             | Rotate Double Picture
             | Pictures [Picture]

blank :: Picture
blank = Pictures []

polygon :: [Point] -> Picture
polygon = Polygon

line :: [Point] -> Picture
line = Line

thickArc :: Double -> Double -> Double -> Double -> Picture
thickArc = ThickArc

arc :: Double -> Double -> Double -> Picture
arc b e r = thickArc b e r 0

circle :: Double -> Picture
circle = arc 0 360

circleSolid :: Double -> Picture
circleSolid r = thickCircle (r/2) r

thickCircle :: Double -> Double -> Picture
thickCircle = thickArc 0 360

text :: String -> Picture
text = Text

color :: Color -> Picture -> Picture
color = Color

translate :: Double -> Double -> Picture -> Picture
translate = Translate

scale :: Double -> Double -> Picture -> Picture
scale = Scale

rotate :: Double -> Picture -> Picture
rotate = Rotate

pictures :: [Picture] -> Picture
pictures = Pictures

rectangleSolid :: Double -> Double -> Picture
rectangleSolid w h = polygon [
    (0-w/2, 0-h/2), (w/2, 0-h/2), (w/2, h/2), (0-w/2, h/2)
    ]

rectangleWire :: Double -> Double -> Picture
rectangleWire w h = line [
    (0-w/2, 0-h/2), (w/2, 0-h/2), (w/2, h/2), (0-w/2, h/2), (0-w/2, 0-h/2)
    ]

pathFromPoints :: Context -> [Point] -> Fay ()
pathFromPoints _   [] = return ()
pathFromPoints ctx ((sx,sy):ps) = do
    moveTo ctx sx sy
    forM_ ps $ \(x,y) -> lineTo ctx x y

drawPicture :: Context -> Transform -> Picture -> Fay ()
drawPicture ctx t (Polygon ps) = do
    withTransform ctx t $ pathFromPoints ctx ps
    fill ctx

drawPicture ctx t (Line ps) = do
    withTransform ctx t $ pathFromPoints ctx ps
    stroke ctx

drawPicture ctx t (ThickArc b e r w) = do
    save ctx
    withTransform ctx t $ do
        when (r > 0) $ canvasArc ctx 0 0 r (b*pi/180) (e*pi/180) False
        closePath ctx
    when (w > 0) $ setLineWidth ctx w
    stroke ctx
    restore ctx

drawPicture ctx t (Text txt) =
    withTransform ctx t $ do
        canvasScale ctx 1 (0-1)
        fillText ctx txt 0 0

drawPicture ctx t (Color (RGBA r g b a) p) = do
    let str = "rgba(" ++ show (r * 100) ++ "%,"
                      ++ show (g * 100) ++ "%,"
                      ++ show (b * 100) ++ "%,"
                      ++ show a ++ ")"
    save ctx
    setStrokeStyle ctx str
    setFillStyle ctx str
    drawPicture ctx t p
    restore ctx

drawPicture ctx t (Translate x y p) = drawPicture ctx (translateTransform x y t) p
drawPicture ctx t (Scale x y p)     = drawPicture ctx (scaleTransform x y t) p
drawPicture ctx t (Rotate r p)      = drawPicture ctx (rotateTransform r t) p
drawPicture ctx t (Pictures ps)     = mapM_ (drawPicture ctx t) ps

withCanvas :: (Element -> Context -> Fay ()) -> Fay ()
withCanvas go = addEventListener "load" False $ const $ do
    canvas <- getElementById "canvas"
    ctx    <- getContext canvas "2d"
    go canvas ctx
    return False

drawOn :: Context -> Picture -> Fay ()
drawOn ctx pic = do
    clearRect ctx 0 0 500 500
    save ctx
    canvasTranslate ctx 250 250
    canvasScale ctx 1 (0-1)
    setTextAlign ctx "left"
    setTextBaseline ctx "alphabetic"
    setLineWidth ctx 0
    setFont ctx "100px Times Roman"
    drawPicture ctx (1,0,0,1,0,0) pic
    restore ctx

displayInCanvas :: Picture -> Fay ()
displayInCanvas pic = withCanvas $ \ canvas ctx -> drawOn ctx pic

animateInCanvas :: (Double -> Picture) -> Fay ()
animateInCanvas anim = withCanvas $ \ canvas ctx -> do
    startTime <- currentTimeMillis
    setInterval 30 $ do
        currentTime <- currentTimeMillis
        let t = (currentTime - startTime) / 1000
        drawOn ctx (anim t)
    return ()

data SimState a = SimState a

withSimState :: (a -> a) -> Ref (SimState a) -> Fay a
withSimState f ref = do
    SimState val <- readRef ref
    let newVal = f val
    writeRef ref (SimState newVal)
    return newVal

-- XXX: This is a hack to pretend to have a decent purely functional
-- random number generator.  It should be replaced by a correct
-- implementation as soon as possible.

unsafeRand :: Double -> Double -> Double
unsafeRand = ffi "Math.random()*%2+%1"

data StdGen = StdGen

newStdGen :: Fay StdGen
newStdGen = return StdGen

splitR :: StdGen -> (StdGen, StdGen)
splitR g = (g, g)

randomR :: (Double, Double) -> StdGen -> (Double, StdGen)
randomR (lo, hi) g = (unsafeRand lo (hi - lo), g)

simulateInCanvas :: (StdGen -> a)
                 -> (Double -> a -> a)
                 -> (a -> Picture)
                 -> Fay ()
simulateInCanvas i s d = withCanvas $ \ canvas ctx -> do
    startTime <- currentTimeMillis
    g <- newStdGen
    valueRef <- newRef (SimState (i g))
    timeRef <- newRef startTime
    setInterval 30 $ do
        lastTime     <- readRef timeRef
        currentTime  <- currentTimeMillis
        let dt     = (currentTime - lastTime) / 1000
        val <- withSimState (s dt) valueRef
        writeRef timeRef currentTime
        drawOn ctx (d val)
    return ()

data GameEvent = KeyPressEvent String
               | KeyReleaseEvent String
               | MousePressEvent Int Point
               | MouseReleaseEvent Int Point
               | MouseMoveEvent Point
  deriving Show
playInCanvas :: (StdGen -> a)
             -> (Double -> a -> a)
             -> (GameEvent -> a -> a)
             -> (a -> Picture)
             -> Fay ()
playInCanvas i s e d = withCanvas $ \ canvas ctx -> do
    startTime <- currentTimeMillis
    g <- newStdGen
    valueRef <- newRef (SimState (i g))
    timeRef <- newRef startTime
    addEventListener "keydown" False $ \ev -> do
        k <- getSpecialKey ev
        if k == "None" then return True else do
            withSimState (e (KeyPressEvent k)) valueRef
            stopEvent ev
            return False
    addEventListener "keypress" False $ \ev -> do
        k <- getPressedKey ev
        if k == "None" then return True else do
            withSimState (e (KeyPressEvent k)) valueRef
            stopEvent ev
            return False
    addEventListener "keyup" False $ \ev -> do
        k <- getReleasedKey ev
        if k == "None" then return True else do
            withSimState (e (KeyReleaseEvent k)) valueRef
            stopEvent ev
            return False
    addEventListener "mousedown" False $ \ev -> do
        focusElement canvas
        x <- mouseToElementX ev
        y <- mouseToElementY ev
        if abs x > 250 || abs y > 250 then return True else do
            b <- getEventMouseButton ev
            withSimState (e (MousePressEvent b (x,y))) valueRef
            stopEvent ev
            return False
    addEventListener "mouseup" False $ \ev -> do
        x <- mouseToElementX ev
        y <- mouseToElementY ev
        if abs x > 250 || abs y > 250 then return True else do
            b <- getEventMouseButton ev
            withSimState (e (MouseReleaseEvent b (x,y))) valueRef
            stopEvent ev
            return False
    addEventListener "mousemove" False $ \ev -> do
        x <- mouseToElementX ev
        y <- mouseToElementY ev
        if abs x > 250 || abs y > 250 then return True else do
            withSimState (e (MouseMoveEvent (x,y))) valueRef
            stopEvent ev
            return False
    setInterval 30 $ do
        lastTime     <- readRef timeRef
        currentTime  <- currentTimeMillis
        let dt     = (currentTime - lastTime) / 1000
        val <- withSimState (s dt) valueRef
        writeRef timeRef currentTime
        drawOn ctx (d val)
    return ()