{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DefaultSignatures        #-}
{-# LANGUAGE DeriveGeneric            #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE JavaScriptFFI            #-}
{-# LANGUAGE KindSignatures           #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE MultiWayIf               #-}
{-# LANGUAGE OverloadedStrings        #-}
{-# LANGUAGE PatternGuards            #-}
{-# LANGUAGE RecordWildCards          #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE StandaloneDeriving       #-}
{-# LANGUAGE DataKinds                #-}

{-
  Copyright 2016 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module CodeWorld.Driver (
    drawingOf,
    animationOf,
    simulationOf,
    interactionOf,
    collaborationOf,
    unsafeCollaborationOf,
    trace
    ) where

import           CodeWorld.Color
import           CodeWorld.Event
import           CodeWorld.Picture
import           CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)
import qualified CodeWorld.CollaborationUI as CUI
import           Control.Concurrent
import           Control.Concurrent.MVar
import           Control.Concurrent.Chan
import           Control.Exception
import           Control.Monad
import           Control.Monad.Trans (liftIO)
import           Data.Char (chr)
import           Data.List (zip4)
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Monoid
import           Data.Serialize
import           Data.Serialize.Text
import qualified Data.Text as T
import           Data.Text (Text, singleton, pack)
import           GHC.Fingerprint.Type
import           GHC.Generics
import           GHC.StaticPtr
import           Numeric
import           System.Environment
import           System.Mem.StableName
import           Text.Read
import           System.Random

#ifdef ghcjs_HOST_OS

import           CodeWorld.Prediction
import           CodeWorld.Message
import           Data.Hashable
import           Data.IORef
import           Data.JSString.Text
import qualified Data.JSString
import           Data.Time.Clock
import           Data.Word
import           GHCJS.DOM
import           GHCJS.DOM.NonElementParentNode
import           GHCJS.DOM.GlobalEventHandlers
import           GHCJS.DOM.Window as Window
import           GHCJS.DOM.Document
import qualified GHCJS.DOM.ClientRect as ClientRect
import           GHCJS.DOM.Element
import           GHCJS.DOM.EventM
import           GHCJS.DOM.MouseEvent
import           GHCJS.DOM.Types (Element, unElement)
import           GHCJS.Foreign
import           GHCJS.Marshal
import           GHCJS.Marshal.Pure
import           GHCJS.Types
import           JavaScript.Web.AnimationFrame
import qualified JavaScript.Web.Canvas as Canvas
import qualified JavaScript.Web.Canvas.Internal as Canvas
import qualified JavaScript.Web.Location as Loc
import qualified JavaScript.Web.MessageEvent as WS
import qualified JavaScript.Web.WebSocket as WS
import           System.IO.Unsafe

#else

import           Data.Time.Clock
import qualified Debug.Trace
import qualified Graphics.Blank as Canvas
import           Graphics.Blank (Canvas)
import           System.IO
import           Text.Printf

#endif

--------------------------------------------------------------------------------
-- The common interface, provided by both implementations below.

-- | Draws a 'Picture'.  This is the simplest CodeWorld entry point.
drawingOf :: Picture -> IO ()

-- | Shows an animation, with a picture for each time given by the parameter.
animationOf :: (Double -> Picture) -> IO ()

-- | Shows a simulation, which is essentially a continuous-time dynamical
-- system described by an initial value and step function.
simulationOf :: world -> (Double -> world -> world) -> (world -> Picture) -> IO ()

-- | Runs an interactive event-driven CodeWorld program.  This is a
-- generalization of simulations that can respond to events like key presses
-- and mouse movement.
interactionOf :: world
              -> (Double -> world -> world)
              -> (Event -> world -> world)
              -> (world -> Picture)
              -> IO ()

-- | Runs an interactive multi-user CodeWorld program, involving multiple
-- participants over the internet.
collaborationOf :: Int
                -> StaticPtr (StdGen -> world)
                -> StaticPtr (Double -> world -> world)
                -> StaticPtr (Int -> Event -> world -> world)
                -> StaticPtr (Int -> world -> Picture)
                -> IO ()

-- | A version of 'collaborationOf' that avoids static pointers, and does not
-- check for consistent parameters.
unsafeCollaborationOf :: Int
                      -> (StdGen -> world)
                      -> (Double -> world -> world)
                      -> (Int -> Event -> world -> world)
                      -> (Int -> world -> Picture)
                      -> IO ()

-- | Prints a debug message to the CodeWorld console when a value is forced.
-- This is equivalent to the similarly named function in `Debug.Trace`, except
-- that it uses the CodeWorld console instead of standard output.
trace :: Text -> a -> a

--------------------------------------------------------------------------------
-- Draw state.  An affine transformation matrix, plus a Bool indicating whether
-- a color has been chosen yet.

type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color)

initialDS :: DrawState
initialDS = (1, 0, 0, 1, 0, 0, Nothing)

translateDS :: Double -> Double -> DrawState -> DrawState
translateDS x y (a,b,c,d,e,f,hc) =
    (a, b, c, d, a*25*x + c*25*y + e, b*25*x + d*25*y + f, hc)

scaleDS :: Double -> Double -> DrawState -> DrawState
scaleDS x y (a,b,c,d,e,f,hc) =
    (x*a, x*b, y*c, y*d, e, f, hc)

rotateDS :: Double -> DrawState -> DrawState
rotateDS r (a,b,c,d,e,f,hc) =
    (a * cos r + c * sin r,
     b * cos r + d * sin r,
     c * cos r - a * sin r,
     d * cos r - b * sin r,
     e, f, hc)

setColorDS :: Color -> DrawState -> DrawState
setColorDS col (a,b,c,d,e,f,Nothing) = (a,b,c,d,e,f,Just col)
setColorDS _ (a,b,c,d,e,f,Just col) = (a,b,c,d,e,f,Just col)

getColorDS :: DrawState -> Maybe Color
getColorDS (a,b,c,d,e,f,col) = col

--------------------------------------------------------------------------------
-- GHCJS implementation of drawing

#ifdef ghcjs_HOST_OS

foreign import javascript unsafe "$1.drawImage($2, $3, $4, $5, $6);"
    js_canvasDrawImage :: Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()

foreign import javascript unsafe "$1.getContext('2d', { alpha: false })"
    js_getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context

foreign import javascript unsafe "performance.now()"
    js_getHighResTimestamp :: IO Double

canvasFromElement :: Element -> Canvas.Canvas
canvasFromElement = Canvas.Canvas . unElement

elementFromCanvas :: Canvas.Canvas -> Element
elementFromCanvas = pFromJSVal . jsval

getTime :: IO Double
getTime = (/ 1000) <$> js_getHighResTimestamp

nextFrame :: IO Double
nextFrame = waitForAnimationFrame >> getTime

withDS :: Canvas.Context -> DrawState -> IO () -> IO ()
withDS ctx (ta,tb,tc,td,te,tf,col) action = do
    Canvas.save ctx
    Canvas.transform ta tb tc td te tf ctx
    Canvas.beginPath ctx
    action
    Canvas.restore ctx

applyColor :: Canvas.Context -> DrawState -> IO ()
applyColor ctx ds = case getColorDS ds of
    Nothing -> do
      Canvas.strokeStyle 0 0 0 1 ctx
      Canvas.fillStyle 0 0 0 1 ctx
    Just (RGBA r g b a) -> do
      Canvas.strokeStyle (round $ r * 255)
                         (round $ g * 255)
                         (round $ b * 255)
                         a ctx
      Canvas.fillStyle (round $ r * 255)
                       (round $ g * 255)
                       (round $ b * 255)
                       a ctx

foreign import javascript unsafe "$1.globalCompositeOperation = $2"
    js_setGlobalCompositeOperation :: Canvas.Context -> JSString -> IO ()

drawCodeWorldLogo :: Canvas.Context -> DrawState -> Int -> Int -> Int -> Int -> IO ()
drawCodeWorldLogo ctx ds x y w h = do
    Just doc <- currentDocument
    Just canvas <- getElementById doc ("cwlogo" :: JSString)
    case getColorDS ds of
        Nothing -> js_canvasDrawImage ctx canvas x y w h
        Just (RGBA r g b a) -> do
            -- This is a tough case.  The best we can do is to allocate an
            -- offscreen buffer as a temporary.
            buf <- Canvas.create w h
            bufctx <- js_getCodeWorldContext buf
            applyColor bufctx ds
            Canvas.fillRect 0 0 (fromIntegral w) (fromIntegral h) bufctx
            js_setGlobalCompositeOperation bufctx "destination-in"
            js_canvasDrawImage bufctx canvas 0 0 w h
            js_canvasDrawImage ctx (elementFromCanvas buf) x y w h

followPath :: Canvas.Context -> [Point] -> Bool -> Bool -> IO ()
followPath ctx [] closed _ = return ()
followPath ctx [p1] closed _ = return ()
followPath ctx ((sx,sy):ps) closed False = do
    Canvas.moveTo (25 * sx) (25 * sy) ctx
    forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x) (25 * y) ctx
    when closed $ Canvas.closePath ctx
followPath ctx [p1, p2] False True = followPath ctx [p1, p2] False False
followPath ctx ps False True = do
    let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps
        dprev = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
        dnext = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
        p     = dprev / (dprev + dnext)
        cx    = x2 + p * (x1 - x3) / 2
        cy    = y2 + p * (y1 - y3) / 2
     in do Canvas.moveTo (25 * x1) (25 * y1) ctx
           Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x2) (25 * y2) ctx
    forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $
        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)
                p   = d1 / (d1 + d2)
                r   = d1 / (dp + d1)
                cx1 = x2 + r * (x3 - x1) / 2
                cy1 = y2 + r * (y3 - y1) / 2
                cx2 = x3 + p * (x2 - x4) / 2
                cy2 = y3 + p * (y2 - y4) / 2
            in  Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)
                                     (25 * x3) (25 * y3) ctx
    let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps
        dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
        d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
        r  = d1 / (dp + d1)
        cx = x2 + r * (x3 - x1) / 2
        cy = y2 + r * (y3 - y1) / 2
     in Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x3) (25 * y3) ctx
followPath ctx ps@(_:(sx,sy):_) True True = do
    Canvas.moveTo (25 * sx) (25 * sy) ctx
    let rep = cycle ps
    forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $
        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)
                p   = d1 / (d1 + d2)
                r   = d1 / (dp + d1)
                cx1 = x2 + r * (x3 - x1) / 2
                cy1 = y2 + r * (y3 - y1) / 2
                cx2 = x3 + p * (x2 - x4) / 2
                cy2 = y3 + p * (y2 - y4) / 2
            in  Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)
                                     (25 * x3) (25 * y3) ctx
    Canvas.closePath ctx

drawFigure :: Canvas.Context -> DrawState -> Double -> IO () -> IO ()
drawFigure ctx ds w figure = do
    withDS ctx ds $ do
        figure
        when (w /= 0) $ do
            Canvas.lineWidth (25 * w) ctx
            applyColor ctx ds
            Canvas.stroke ctx
    when (w == 0) $ do
        Canvas.lineWidth 1 ctx
        applyColor ctx ds
        Canvas.stroke ctx

fontString :: TextStyle -> Font -> JSString
fontString style font = stylePrefix style <> "25px " <> fontName font
  where stylePrefix Plain        = ""
        stylePrefix Bold         = "bold "
        stylePrefix Italic       = "italic "
        fontName SansSerif       = "sans-serif"
        fontName Serif           = "serif"
        fontName Monospace       = "monospace"
        fontName Handwriting     = "cursive"
        fontName Fancy           = "fantasy"
        fontName (NamedFont txt) = "\"" <> textToJSString (T.filter (/= '"') txt) <> "\""

drawPicture :: Canvas.Context -> DrawState -> Picture -> IO ()
drawPicture ctx ds (Polygon ps smooth) = do
    withDS ctx ds $ followPath ctx ps True smooth
    applyColor ctx ds
    Canvas.fill ctx
drawPicture ctx ds (Path ps w closed smooth) = do
    drawFigure ctx ds w $ followPath ctx ps closed smooth
drawPicture ctx ds (Sector b e r) = withDS ctx ds $ do
    Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx
    Canvas.lineTo 0 0 ctx
    applyColor ctx ds
    Canvas.fill ctx
drawPicture ctx ds (Arc b e r w) = do
    drawFigure ctx ds w $ do
        Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx
drawPicture ctx ds (Text sty fnt txt) = withDS ctx ds $ do
    Canvas.scale 1 (-1) ctx
    applyColor ctx ds
    Canvas.font (fontString sty fnt) ctx
    Canvas.fillText (textToJSString txt) 0 0 ctx
drawPicture ctx ds Logo = withDS ctx ds $ do
    Canvas.scale 1 (-1) ctx
    drawCodeWorldLogo ctx ds (-225) (-50) 450 100
drawPicture ctx ds (Color col p)     = drawPicture ctx (setColorDS col ds) p
drawPicture ctx ds (Translate x y p) = drawPicture ctx (translateDS x y ds) p
drawPicture ctx ds (Scale x y p)     = drawPicture ctx (scaleDS x y ds) p
drawPicture ctx ds (Rotate r p)      = drawPicture ctx (rotateDS r ds) p
drawPicture ctx ds (Pictures ps)     = mapM_ (drawPicture ctx ds) (reverse ps)

drawFrame :: Canvas.Context -> Picture -> IO ()
drawFrame ctx pic = do
    Canvas.fillStyle 255 255 255 1 ctx
    Canvas.fillRect (-250) (-250) 500 500 ctx
    drawPicture ctx initialDS pic

setupScreenContext :: Element -> ClientRect.ClientRect -> IO Canvas.Context
setupScreenContext canvas rect = do
    cw <- ClientRect.getWidth rect
    ch <- ClientRect.getHeight rect
    ctx <- js_getCodeWorldContext (canvasFromElement canvas)
    Canvas.save ctx
    Canvas.translate (realToFrac cw / 2) (realToFrac ch / 2) ctx
    Canvas.scale (realToFrac cw / 500) (- realToFrac ch / 500) ctx
    Canvas.lineWidth 0 ctx
    Canvas.textAlign Canvas.Center ctx
    Canvas.textBaseline Canvas.Middle ctx
    return ctx

setCanvasSize :: Element -> Element -> IO ()
setCanvasSize target canvas = do
    rect <- getBoundingClientRect canvas
    cx <- ClientRect.getWidth rect
    cy <- ClientRect.getHeight rect
    setAttribute target ("width" :: JSString) (show (round cx))
    setAttribute target ("height" :: JSString) (show (round cy))

display :: Picture -> IO ()
display pic = do
    Just window <- currentWindow
    Just doc <- currentDocument
    Just canvas <- getElementById doc ("screen" :: JSString)
    on window resize $ liftIO (draw canvas)
    draw canvas
  where
    draw canvas = do
        setCanvasSize canvas canvas
        rect <- getBoundingClientRect canvas
        ctx <- setupScreenContext canvas rect
        drawFrame ctx pic
        Canvas.restore ctx

drawingOf pic = display pic `catch` reportError


--------------------------------------------------------------------------------
-- Stand-alone implementation of drawing

#else

withDS :: DrawState -> Canvas () -> Canvas ()
withDS (ta,tb,tc,td,te,tf,col) action =
    Canvas.saveRestore $ do
        Canvas.transform (ta, tb, tc, td, te, tf)
        Canvas.beginPath ()
        action

applyColor :: DrawState -> Canvas ()
applyColor ds = case getColorDS ds of
    Nothing -> do
      Canvas.strokeStyle "black"
      Canvas.fillStyle   "black"
    Just (RGBA r g b a) -> do
      let style = pack $ printf "rgba(%.0f,%.0f,%.0f,%f)" (r*255) (g*255) (b*255) a
      Canvas.strokeStyle style
      Canvas.fillStyle   style


drawFigure :: DrawState -> Double -> Canvas () -> Canvas ()
drawFigure ds w figure = do
    withDS ds $ do
        figure
        when (w /= 0) $ do
            Canvas.lineWidth (25 * w)
            applyColor ds
            Canvas.stroke ()
    when (w == 0) $ do
        Canvas.lineWidth 1
        applyColor ds
        Canvas.stroke ()

followPath :: [Point] -> Bool -> Bool -> Canvas ()
followPath [] closed _ = return ()
followPath [p1] closed _ = return ()
followPath ((sx,sy):ps) closed False = do
    Canvas.moveTo (25 * sx, 25 * sy)
    forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x, 25 * y)
    when closed $ Canvas.closePath ()
followPath [p1, p2] False True = followPath [p1, p2] False False
followPath ps False True = do
    let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps
        dprev = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
        dnext = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
        p     = dprev / (dprev + dnext)
        cx    = x2 + p * (x1 - x3) / 2
        cy    = y2 + p * (y1 - y3) / 2
     in do Canvas.moveTo (25 * x1, 25 * y1)
           Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x2, 25 * y2)
    forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $
        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)
                p   = d1 / (d1 + d2)
                r   = d1 / (dp + d1)
                cx1 = x2 + r * (x3 - x1) / 2
                cy1 = y2 + r * (y3 - y1) / 2
                cx2 = x3 + p * (x2 - x4) / 2
                cy2 = y3 + p * (y2 - y4) / 2
            in  Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2
                                     , 25 * x3,  25 * y3)
    let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps
        dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
        d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
        r  = d1 / (dp + d1)
        cx = x2 + r * (x3 - x1) / 2
        cy = y2 + r * (y3 - y1) / 2
     in Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x3, 25 * y3)
followPath ps@(_:(sx,sy):_) True True = do
    Canvas.moveTo (25 * sx, 25 * sy)
    let rep = cycle ps
    forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $
        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->
            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)
                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)
                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)
                p   = d1 / (d1 + d2)
                r   = d1 / (dp + d1)
                cx1 = x2 + r * (x3 - x1) / 2
                cy1 = y2 + r * (y3 - y1) / 2
                cx2 = x3 + p * (x2 - x4) / 2
                cy2 = y3 + p * (y2 - y4) / 2
            in  Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2
                                     , 25 * x3, 25 * y3)
    Canvas.closePath ()


fontString :: TextStyle -> Font -> Text
fontString style font = stylePrefix style <> "25px " <> fontName font
  where stylePrefix Plain        = ""
        stylePrefix Bold         = "bold "
        stylePrefix Italic       = "italic "
        fontName SansSerif       = "sans-serif"
        fontName Serif           = "serif"
        fontName Monospace       = "monospace"
        fontName Handwriting     = "cursive"
        fontName Fancy           = "fantasy"
        fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\""

drawPicture :: DrawState -> Picture -> Canvas ()
drawPicture ds (Polygon ps smooth) = do
    withDS ds $ followPath ps True smooth
    applyColor ds
    Canvas.fill ()
drawPicture ds (Path ps w closed smooth) = do
    drawFigure ds w $ followPath ps closed smooth
drawPicture ds (Sector b e r) = withDS ds $ do
    Canvas.arc (0, 0, 25 * abs r, b, e,  b > e)
    Canvas.lineTo (0, 0)
    applyColor ds
    Canvas.fill ()
drawPicture ds (Arc b e r w) = do
    drawFigure ds w $ do
        Canvas.arc (0, 0, 25 * abs r, b, e, b > e)
drawPicture ds (Text sty fnt txt) = withDS ds $ do
    Canvas.scale (1, -1)
    applyColor ds
    Canvas.font (fontString sty fnt)
    Canvas.fillText (txt, 0, 0)
drawPicture ds Logo              = return () -- Unimplemented
drawPicture ds (Color col p)     = drawPicture (setColorDS col ds) p
drawPicture ds (Translate x y p) = drawPicture (translateDS x y ds) p
drawPicture ds (Scale x y p)     = drawPicture (scaleDS x y ds) p
drawPicture ds (Rotate r p)      = drawPicture (rotateDS r ds) p
drawPicture ds (Pictures ps)     = mapM_ (drawPicture ds) (reverse ps)

setupScreenContext :: (Int, Int) -> Canvas ()
setupScreenContext (cw, ch) = do
    -- blank before transformation (canvas might be non-sqare)
    Canvas.fillStyle "white"
    Canvas.fillRect (0,0,fromIntegral cw,fromIntegral ch)

    Canvas.translate (realToFrac cw / 2, realToFrac ch / 2)
    let s = min (realToFrac cw / 500) (realToFrac ch / 500)
    Canvas.scale (s, -s)
    Canvas.lineWidth 0
    Canvas.textAlign Canvas.CenterAnchor
    Canvas.textBaseline Canvas.MiddleBaseline

type Port = Int

readPortFromEnv :: String -> Port -> IO Port
readPortFromEnv envName defaultPort = do
    ms <- lookupEnv envName
    return (fromMaybe defaultPort (ms >>= readMaybe))

runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO ()
runBlankCanvas act = do
    port <- readPortFromEnv "CODEWORLD_API_PORT" 3000
    let options = (fromIntegral port) { Canvas.events =
            [ "mousedown", "mouseup", "mousemove", "keydown", "keyup"]
        }
    putStrLn $ printf "Open me on http://127.0.0.1:%d/" (Canvas.port options)
    Canvas.blankCanvas options $ \context -> do
        putStrLn "Program is starting..."
        act context

display :: Picture -> IO ()
display pic = runBlankCanvas $ \context ->
    Canvas.send context $ Canvas.saveRestore $ do
        let rect = (Canvas.width context, Canvas.height context)
        setupScreenContext rect
        drawPicture initialDS pic

drawingOf pic = display pic `catch` reportError
#endif


--------------------------------------------------------------------------------
-- Common event handling and core interaction code

keyCodeToText :: Word -> Text
keyCodeToText n = case n of
    _ | n >= 47  && n <= 90  -> fromAscii n
    _ | n >= 96  && n <= 105 -> fromNum (n - 96)
    _ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111)
    3                        -> "Cancel"
    6                        -> "Help"
    8                        -> "Backspace"
    9                        -> "Tab"
    12                       -> "5"
    13                       -> "Enter"
    16                       -> "Shift"
    17                       -> "Ctrl"
    18                       -> "Alt"
    19                       -> "Break"
    20                       -> "CapsLock"
    27                       -> "Esc"
    32                       -> " "
    33                       -> "PageUp"
    34                       -> "PageDown"
    35                       -> "End"
    36                       -> "Home"
    37                       -> "Left"
    38                       -> "Up"
    39                       -> "Right"
    40                       -> "Down"
    42                       -> "*"
    43                       -> "+"
    44                       -> "PrintScreen"
    45                       -> "Insert"
    46                       -> "Delete"
    106                      -> "*"
    107                      -> "+"
    108                      -> "Separator"
    109                      -> "-"
    110                      -> "."
    111                      -> "/"
    144                      -> "NumLock"
    145                      -> "ScrollLock"
    186                      -> ";"
    187                      -> "="
    188                      -> ","
    189                      -> "-"
    190                      -> "."
    191                      -> "/"
    192                      -> "`"
    219                      -> "["
    220                      -> "\\"
    221                      -> "]"
    222                      -> "'"
    _                        -> "Unknown:" <> fromNum n
  where fromAscii n = singleton (chr (fromIntegral n))
        fromNum   n = pack (show (fromIntegral n))

isUniversallyConstant :: (a -> s -> s) -> s -> IO Bool
isUniversallyConstant f old = falseOr $ do
    oldName <- makeStableName old
    genName <- makeStableName $! (f undefined old)
    return (genName == oldName)
  where falseOr x = x `catch` \(e :: SomeException) -> return False

applyIfModifying :: (s -> IO s) -> s -> IO (Maybe s)
applyIfModifying f s0 = do
    oldName <- makeStableName $! s0
    s1      <- f s0
    newName <- makeStableName $! s1
    if newName /= oldName then return (Just s1)
                          else return Nothing

modifyMVarIfNeeded :: MVar s -> (s -> IO s) -> IO Bool
modifyMVarIfNeeded var f = modifyMVar var $ \s0 -> do
    ms1 <- applyIfModifying f s0
    case ms1 of Nothing -> return (s0, False)
                Just s1 -> return (s1, True)

data GameToken
    = FullToken {
          tokenDeployHash :: Text,
          tokenNumPlayers :: Int,
          tokenInitial :: StaticKey,
          tokenStep :: StaticKey,
          tokenEvent :: StaticKey,
          tokenDraw :: StaticKey
      }
    | PartialToken {
          tokenDeployHash :: Text
      }
    | NoToken
    deriving Generic

deriving instance Generic Fingerprint
instance Serialize Fingerprint
instance Serialize GameToken

--------------------------------------------------------------------------------
-- GHCJS event handling and core interaction code

#ifdef ghcjs_HOST_OS

getMousePos :: IsMouseEvent e => Element -> EventM w e Point
getMousePos canvas = do
    (ix, iy) <- mouseClientXY
    liftIO $ do
        rect <- getBoundingClientRect canvas
        cx <- ClientRect.getLeft rect
        cy <- ClientRect.getTop rect
        cw <- ClientRect.getWidth rect
        ch <- ClientRect.getHeight rect
        return (20 * fromIntegral (ix - round cx) / realToFrac cw - 10,
                20 * fromIntegral (round cy - iy) / realToFrac cw + 10)

fromButtonNum :: Word -> Maybe MouseButton
fromButtonNum 0 = Just LeftButton
fromButtonNum 1 = Just MiddleButton
fromButtonNum 2 = Just RightButton
fromButtonNum _ = Nothing

onEvents :: Element -> (Event -> IO ()) -> IO ()
onEvents canvas handler = do
    Just window <- currentWindow
    on window keyDown $ do
        code <- uiKeyCode
        let keyName = keyCodeToText code
        when (keyName /= "") $ do
            liftIO $ handler (KeyPress keyName)
            preventDefault
            stopPropagation
    on window keyUp $ do
        code <- uiKeyCode
        let keyName = keyCodeToText code
        when (keyName /= "") $ do
            liftIO $ handler (KeyRelease keyName)
            preventDefault
            stopPropagation
    on window mouseDown $ do
        button <- mouseButton
        case fromButtonNum button of
            Nothing  -> return ()
            Just btn -> do
                pos <- getMousePos canvas
                liftIO $ handler (MousePress btn pos)
    on window mouseUp $ do
        button <- mouseButton
        case fromButtonNum button of
            Nothing  -> return ()
            Just btn -> do
                pos <- getMousePos canvas
                liftIO $ handler (MouseRelease btn pos)
    on window mouseMove $ do
        pos <- getMousePos canvas
        liftIO $ handler (MouseMovement pos)
    return ()

encodeEvent :: (Timestamp, Maybe Event) -> String
encodeEvent = show

decodeEvent :: String -> Maybe (Timestamp, Maybe Event)
decodeEvent = readMaybe

data GameState s
    = Main       (UIState SMain)
    | Connecting WS.WebSocket (UIState SConnect)
    | Waiting    WS.WebSocket GameId PlayerId (UIState SWait)
    | Running    WS.WebSocket GameId Timestamp PlayerId (Future s)

isRunning :: GameState s -> Bool
isRunning Running{} = True
isRunning _         = False

gameTime :: GameState s -> Timestamp -> Double
gameTime (Running _ _ tstart _ _) t = t - tstart
gameTime _ _                        = 0

-- It's worth trying to keep the canonical animation rate exactly representable
-- as a float, to minimize the chance of divergence due to rounding error.
gameRate :: Double
gameRate = 1/16

gameStep :: (Double -> s -> s) -> Double -> GameState s -> GameState s
gameStep _    t (Main s)
    = Main (CUI.step t s)
gameStep _    t (Connecting ws s)
    = Connecting ws (CUI.step t s)
gameStep _    t (Waiting ws gid pid s)
    = Waiting ws gid pid (CUI.step t s)
gameStep step t (Running ws gid tstart pid s)
    = Running ws gid tstart pid (currentTimePasses step gameRate (t - tstart) s)

gameDraw :: (Double -> s -> s)
         -> (PlayerId -> s -> Picture)
         -> GameState s
         -> Timestamp
         -> Picture
gameDraw _    _    (Main s)                   _ = CUI.picture s
gameDraw _    _    (Connecting _ s)           _ = CUI.picture s
gameDraw _    _    (Waiting _ _ _ s)          _ = CUI.picture s
gameDraw step draw (Running _ _ tstart pid s) t = draw pid (currentState step gameRate (t - tstart) s)

handleServerMessage :: Int
                    -> (StdGen -> s)
                    -> (Double -> s -> s)
                    -> (PlayerId -> Event -> s -> s)
                    -> MVar (GameState s)
                    -> ServerMessage
                    -> IO ()
handleServerMessage numPlayers initial stepHandler eventHandler gsm sm = do
    modifyMVar_ gsm $ \gs -> do
        t <- getTime
        case (sm, gs) of
            (GameAborted,         _) ->
                return initialGameState
            (JoinedAs pid gid,    Connecting ws s) ->
                return (Waiting ws gid pid (CUI.startWaiting gid s))
            (PlayersWaiting m n,  Waiting ws gid pid s) ->
                return (Waiting ws gid pid (CUI.updatePlayers n m s))
            (Started,             Waiting ws gid pid _) ->
                return (Running ws gid t pid (initFuture (initial (mkStdGen (hash gid))) numPlayers))
            (OutEvent pid eo,     Running ws gid tstart mypid s) ->
                case decodeEvent eo of
                    Just (t',event) ->
                        let ours   = pid == mypid
                            func   = eventHandler pid <$> event -- might be a ping (Nothing)
                            result | ours      = s -- we already took care of our events
                                   | otherwise = addEvent stepHandler gameRate mypid t' func s
                        in  return (Running ws gid tstart mypid result)
                    Nothing -> return (Running ws gid tstart mypid s)
            _ -> return gs
    return ()

gameHandle :: Int
            -> (StdGen -> s)
            -> (Double -> s -> s)
            -> (PlayerId -> Event -> s -> s)
            -> GameToken
            -> MVar (GameState s)
            -> Event
            -> IO ()
gameHandle numPlayers initial stepHandler eventHandler token gsm event = do
    gs <- takeMVar gsm
    case gs of
        Main s -> case CUI.event event s of
            ContinueMain s' -> do
                putMVar gsm (Main s')
            Create s' -> do
                ws <- connectToGameServer (handleServerMessage numPlayers initial stepHandler eventHandler gsm)
                sendClientMessage ws (NewGame numPlayers (encode token))
                putMVar gsm (Connecting ws s')
            Join gid s' -> do
                ws <- connectToGameServer (handleServerMessage numPlayers initial stepHandler eventHandler gsm)
                sendClientMessage ws (JoinGame gid (encode token))
                putMVar gsm (Connecting ws s')
        Connecting ws s -> case CUI.event event s of
            ContinueConnect s' -> do
                putMVar gsm (Connecting ws s')
            CancelConnect s' -> do
                WS.close Nothing Nothing ws
                putMVar gsm (Main s')
        Waiting ws gid pid s -> case CUI.event event s of
            ContinueWait s' -> do
                putMVar gsm (Waiting ws gid pid s')
            CancelWait s' -> do
                WS.close Nothing Nothing ws
                putMVar gsm (Main s')

        Running ws gid tstart pid f -> do
            t   <- getTime
            let gameState0 = currentState stepHandler gameRate (t - tstart) f
            let eventFun = eventHandler pid event
            ms1 <- (return . eventFun) `applyIfModifying` gameState0
            case ms1 of
                Nothing -> do
                    putMVar gsm gs
                Just s1 -> do
                    sendClientMessage ws (InEvent (encodeEvent (gameTime gs t, Just event)))
                    let f1 = addEvent stepHandler gameRate pid (t - tstart) (Just eventFun) f
                    putMVar gsm (Running ws gid tstart pid f1)

getWebSocketURL :: IO JSString
getWebSocketURL = do
    loc      <- Loc.getWindowLocation
    proto    <- Loc.getProtocol loc
    hostname <- Loc.getHostname loc

    let url = case proto of
            "http:"  -> "ws://" <> hostname <> ":9160/gameserver"
            "https:" -> "wss://" <> hostname <> "/gameserver"

    return url

connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket
connectToGameServer handleServerMessage = do
    let handleWSRequest m = do
        maybeSM <- decodeServerMessage m
        case maybeSM of
            Nothing -> return ()
            Just sm -> handleServerMessage sm

    wsURL <- getWebSocketURL
    let req = WS.WebSocketRequest
            { url = wsURL
            , protocols = []
            , onClose = Just $ \_ -> handleServerMessage GameAborted
            , onMessage = Just handleWSRequest
            }
    WS.connect req
  where
    decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)
    decodeServerMessage m = case WS.getData m of
        WS.StringData str -> do
            return $ readMaybe (Data.JSString.unpack str)
        _ -> return Nothing

    encodeClientMessage :: ClientMessage -> JSString
    encodeClientMessage m = Data.JSString.pack (show m)

sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()
sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws
  where
    encodeClientMessage :: ClientMessage -> JSString
    encodeClientMessage m = Data.JSString.pack (show m)

initialGameState :: GameState s
initialGameState = Main CUI.initial

runGame :: GameToken
        -> Int
        -> (StdGen -> s)
        -> (Double -> s -> s)
        -> (Int -> Event -> s -> s)
        -> (Int -> s -> Picture)
        -> IO ()
runGame token numPlayers initial stepHandler eventHandler drawHandler = do
    Just window <- currentWindow
    Just doc <- currentDocument
    Just canvas <- getElementById doc ("screen" :: JSString)
    offscreenCanvas <- Canvas.create 500 500

    setCanvasSize canvas canvas
    setCanvasSize (elementFromCanvas offscreenCanvas) canvas
    on window resize $ do
        liftIO $ setCanvasSize canvas canvas
        liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas

    currentGameState <- newMVar initialGameState

    onEvents canvas $ gameHandle numPlayers initial stepHandler eventHandler token currentGameState

    screen <- js_getCodeWorldContext (canvasFromElement canvas)

    let go t0 lastFrame = do
            gs  <- readMVar currentGameState
            let pic = gameDraw stepHandler drawHandler gs t0
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ do
                rect <- getBoundingClientRect canvas
                buffer <- setupScreenContext (elementFromCanvas offscreenCanvas)
                                             rect
                drawFrame buffer pic
                Canvas.restore buffer

                rect <- getBoundingClientRect canvas
                cw <- ClientRect.getWidth rect
                ch <- ClientRect.getHeight rect
                js_canvasDrawImage screen (elementFromCanvas offscreenCanvas)
                                   0 0 (round cw) (round ch)

            t1 <- nextFrame
            modifyMVar_ currentGameState $ return . gameStep stepHandler t1
            go t1 picFrame

    t0 <- getTime
    nullFrame <- makeStableName undefined
    initialStateName <- makeStableName $! initialGameState
    go t0 nullFrame

run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()
run initial stepHandler eventHandler drawHandler = do
    Just window <- currentWindow
    Just doc <- currentDocument
    Just canvas <- getElementById doc ("screen" :: JSString)
    offscreenCanvas <- Canvas.create 500 500

    setCanvasSize canvas canvas
    setCanvasSize (elementFromCanvas offscreenCanvas) canvas
    on window resize $ do
        liftIO $ setCanvasSize canvas canvas
        liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas

    currentState <- newMVar initial
    eventHappened <- newMVar ()

    onEvents canvas $ \event -> do
        changed <- modifyMVarIfNeeded currentState (return . eventHandler event)
        when changed $ void $ tryPutMVar eventHappened ()

    screen <- js_getCodeWorldContext (canvasFromElement canvas)

    let go t0 lastFrame lastStateName needsTime = do
            pic <- drawHandler <$> readMVar currentState
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ do
                rect <- getBoundingClientRect canvas
                buffer <- setupScreenContext (elementFromCanvas offscreenCanvas)
                                             rect
                drawFrame buffer pic
                Canvas.restore buffer

                rect <- getBoundingClientRect canvas
                cw <- ClientRect.getWidth rect
                ch <- ClientRect.getHeight rect
                js_canvasDrawImage screen (elementFromCanvas offscreenCanvas)
                                   0 0 (round cw) (round ch)

            t1 <- if
              | needsTime -> do
                  t1 <- nextFrame
                  let dt = min (t1 - t0) 0.25
                  modifyMVar_ currentState (return . stepHandler dt)
                  return t1
              | otherwise -> do
                  takeMVar eventHappened
                  getTime

            nextState <- readMVar currentState
            nextStateName <- makeStableName $! nextState
            nextNeedsTime <- if
                | nextStateName /= lastStateName -> return True
                | not needsTime -> return False
                | otherwise     -> not <$> isUniversallyConstant stepHandler nextState

            go t1 picFrame nextStateName nextNeedsTime

    t0 <- getTime
    nullFrame <- makeStableName undefined
    initialStateName <- makeStableName $! initial
    go t0 nullFrame initialStateName True

--------------------------------------------------------------------------------
-- Stand-Alone event handling and core interaction code

#else

fromButtonNum :: Int -> Maybe MouseButton
fromButtonNum 1 = Just LeftButton
fromButtonNum 2 = Just MiddleButton
fromButtonNum 3 = Just RightButton
fromButtonNum _ = Nothing

getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double)
getMousePos (w,h) (x,y) = ((x - fromIntegral w / 2)/s, -(y - fromIntegral h / 2)/s)
  where
   s = min (realToFrac w / 20) (realToFrac h / 20)

toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event
toEvent rect Canvas.Event {..}
    | eType == "keydown"
    , Just code <- eWhich
    = Just $ KeyPress (keyCodeToText (fromIntegral code))
    | eType == "keyup"
    , Just code <- eWhich
    = Just $ KeyRelease (keyCodeToText (fromIntegral code))
    | eType == "mousedown"
    , Just button <- eWhich >>= fromButtonNum
    , Just pos <- getMousePos rect <$> ePageXY
    = Just $ MousePress button pos
    | eType == "mouseup"
    , Just button <- eWhich >>= fromButtonNum
    , Just pos <- getMousePos rect <$> ePageXY
    = Just $ MouseRelease button pos
    | eType == "mousemove"
    , Just pos <- getMousePos rect <$> ePageXY
    = Just $ MouseMovement pos
    | otherwise
    = Nothing

onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()
onEvents context rect handler = void $ forkIO $ forever $ do
    maybeEvent <- toEvent rect <$> Canvas.wait context
    case maybeEvent of
        Nothing -> return ()
        Just event -> handler event

run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()
run initial stepHandler eventHandler drawHandler = runBlankCanvas $ \context -> do
    let rect = (Canvas.width context, Canvas.height context)
    offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect

    currentState <- newMVar initial
    eventHappened <- newMVar ()

    onEvents context rect $ \event -> do
        modifyMVar_ currentState (return . eventHandler event)
        tryPutMVar eventHappened ()
        return ()

    let go t0 lastFrame lastStateName needsTime = do
            pic <- drawHandler <$> readMVar currentState
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ do
                Canvas.send context $ do
                    Canvas.with offscreenCanvas $
                        Canvas.saveRestore $ do
                            setupScreenContext rect
                            drawPicture initialDS pic
                    Canvas.drawImageAt (offscreenCanvas, 0, 0)

            t1 <- if
              | needsTime -> do
                  tn <- getCurrentTime
                  threadDelay $ max 0 (50000 - (round ((tn `diffUTCTime` t0) * 1000000)))
                  t1 <- getCurrentTime
                  let dt = realToFrac (t1 `diffUTCTime` t0)
                  modifyMVar_ currentState (return . stepHandler dt)
                  return t1
              | otherwise -> do
                  takeMVar eventHappened
                  getCurrentTime

            nextState <- readMVar currentState
            nextStateName <- makeStableName $! nextState
            nextNeedsTime <- if nextStateName == lastStateName
                then not <$> isUniversallyConstant stepHandler nextState
                else return True

            go t1 picFrame nextStateName nextNeedsTime

    t0 <- getCurrentTime
    nullFrame <- makeStableName undefined
    initialStateName <- makeStableName $! initial
    go t0 nullFrame initialStateName True

getDeployHash :: IO Text
getDeployHash = error "game API unimplemented in stand-alone interface mode"

runGame :: GameToken
        -> Int
        -> (StdGen -> s)
        -> (Double -> s -> s)
        -> (Int -> Event -> s -> s)
        -> (Int -> s -> Picture)
        -> IO ()
runGame = error "game API unimplemented in stand-alone interface mode"
#endif


--------------------------------------------------------------------------------
-- Common code for game interface

unsafeCollaborationOf numPlayers initial step event draw = do
    dhash <- getDeployHash
    let token = PartialToken dhash
    runGame token numPlayers initial step event draw `catch` reportError
  where token = NoToken

collaborationOf numPlayers initial step event draw = do
    dhash <- getDeployHash
    let token = FullToken {
                    tokenDeployHash = dhash,
                    tokenNumPlayers = numPlayers,
                    tokenInitial = staticKey initial,
                    tokenStep = staticKey step,
                    tokenEvent = staticKey event,
                    tokenDraw = staticKey draw
                }
    runGame token numPlayers (deRefStaticPtr initial) (deRefStaticPtr step)
            (deRefStaticPtr event) (deRefStaticPtr draw)

--------------------------------------------------------------------------------
-- Common code for interaction, animation and simulation interfaces

interactionOf initial step event draw =
    run initial step event draw `catch` reportError

data Wrapped a = Wrapped {
    state          :: a,
    paused         :: Bool,
    mouseMovedTime :: Double
    } deriving Show

data Control :: * -> * where
  PlayButton    :: Control a
  PauseButton   :: Control a
  StepButton    :: Control a
  RestartButton :: Control Double
  BackButton    :: Control Double
  TimeLabel     :: Control Double

wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a
wrappedStep f dt w = w {
    state          = if paused w then state w else f dt (state w),
    mouseMovedTime = mouseMovedTime w + dt
    }

wrappedEvent :: (Wrapped a -> [Control a])
      -> (Double -> a -> a)
      -> Event -> Wrapped a -> Wrapped a
wrappedEvent _     _ (MouseMovement _)         w
    = w { mouseMovedTime = 0 }
wrappedEvent ctrls f (MousePress LeftButton p) w
    = (foldr (handleControl f p) w (ctrls w)) { mouseMovedTime = 0 }
wrappedEvent _     _ _                         w = w

handleControl :: (Double -> a -> a)
              -> Point
              -> Control a
              -> Wrapped a
              -> Wrapped a
handleControl _ (x,y) RestartButton w
  | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6
      = w { state = 0 }
handleControl _ (x,y) PlayButton    w
  | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6
      = w { paused = False }
handleControl _ (x,y) PauseButton   w
  | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6
      = w { paused = True }
handleControl _ (x,y) BackButton    w
  | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6
      = w { state = max 0 (state w - 0.1) }
handleControl f (x,y) StepButton    w
  | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6
      = w { state = f 0.1 (state w) }
handleControl _ _     _             w = w

wrappedDraw :: (Wrapped a -> [Control a])
     -> (a -> Picture)
     -> Wrapped a -> Picture
wrappedDraw ctrls f w = drawControlPanel ctrls w <> f (state w)

drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture
drawControlPanel ctrls w
  | alpha > 0 = pictures [ drawControl w alpha c | c <- ctrls w ]
  | otherwise = blank
  where alpha | mouseMovedTime w < 4.5  = 1
              | mouseMovedTime w < 5.0  = 10 - 2 * mouseMovedTime w
              | otherwise               = 0

drawControl :: Wrapped a -> Double -> Control a -> Picture
drawControl _ alpha RestartButton = translated (-9) (-9) p
  where p = colored (RGBA 0   0   0   alpha)
                    (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>
                     translated 0.173 (-0.1) (solidRectangle 0.17 0.17))
         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)
         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)

drawControl _ alpha PlayButton = translated (-8) (-9) p
  where p = colored (RGBA 0   0   0   alpha)
                    (solidPolygon [ (-0.2, 0.25), (-0.2, -0.25), (0.2, 0) ])
         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)
         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)

drawControl _ alpha PauseButton = translated (-8) (-9) p
  where p = colored (RGBA 0   0   0   alpha)
                    (translated (-0.15) 0 (solidRectangle 0.2 0.6) <>
                     translated ( 0.15) 0 (solidRectangle 0.2 0.6))
         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)
         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)

drawControl _ alpha BackButton = translated (-7) (-9) p
  where p = colored (RGBA 0   0   0   alpha)
                    (translated 0.15 0 (solidRectangle 0.2 0.5) <>
                     solidPolygon [ (-0.05, 0.25), (-0.05, -0.25), (-0.3, 0) ])
         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)
         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)

drawControl _ alpha StepButton = translated (-6) (-9) p
  where p = colored (RGBA 0   0   0   alpha)
                    (translated (-0.15) 0 (solidRectangle 0.2 0.5) <>
                     solidPolygon [ (0.05, 0.25), (0.05, -0.25), (0.3, 0) ])
         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)
         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)

drawControl w alpha TimeLabel = translated (8) (-9) p
  where p = colored (RGBA 0   0   0   alpha)
                    (scaled 0.5 0.5 $
                        text (pack (showFFloatAlt (Just 4) (state w) "s")))
         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      3.0 0.8)
         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)

animationControls :: Wrapped Double -> [Control Double]
animationControls w
  | mouseMovedTime w > 5    = []
  | paused w && state w > 0 = [ RestartButton, PlayButton, StepButton,
                                BackButton, TimeLabel ]
  | paused w                = [ RestartButton, PlayButton, StepButton,
                                TimeLabel ]
  | otherwise               = [ RestartButton, PauseButton, TimeLabel ]

animationOf f =
    interactionOf initial
                  (wrappedStep (+))
                  (wrappedEvent animationControls (+))
                  (wrappedDraw animationControls f)
  where initial = Wrapped {
            state          = 0,
            paused         = False,
            mouseMovedTime = 1000
        }

simulationControls :: Wrapped w -> [Control w]
simulationControls w
  | mouseMovedTime w > 5 = []
  | paused w             = [ PlayButton, StepButton ]
  | otherwise            = [ PauseButton ]

simulationOf simInitial simStep simDraw =
    interactionOf initial
                  (wrappedStep simStep)
                  (wrappedEvent simulationControls simStep)
                  (wrappedDraw simulationControls simDraw)
  where initial = Wrapped {
            state          = simInitial,
            paused         = False,
            mouseMovedTime = 1000
        }


#ifdef ghcjs_HOST_OS
--------------------------------------------------------------------------------
--- GHCJS implementation of tracing and error handling

foreign import javascript unsafe "window.reportRuntimeError($1, $2);"
    js_reportRuntimeError :: Bool -> JSString -> IO ()

trace msg x = unsafePerformIO $ do
    js_reportRuntimeError False (textToJSString msg)
    return x

reportError :: SomeException -> IO ()
reportError e = js_reportRuntimeError True (textToJSString (pack (show e)))

foreign import javascript "/[&?]dhash=(.{22})/.exec(window.location.search)[1]"
    js_deployHash :: IO JSVal

getDeployHash :: IO Text
getDeployHash = pFromJSVal <$> js_deployHash

--------------------------------------------------------------------------------
--- Stand-alone implementation of tracing and error handling
#else

trace = Debug.Trace.trace . T.unpack

reportError :: SomeException -> IO ()
reportError e = hPrint stderr e

#endif