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

{-
  Copyright 2019 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
    , activityOf
    , debugActivityOf
    , groupActivityOf
    , unsafeGroupActivityOf
    , simulationOf
    , debugSimulationOf
    , interactionOf
    , debugInteractionOf
    , collaborationOf
    , unsafeCollaborationOf
    , trace
    ) where

import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)
import qualified CodeWorld.CollaborationUI as CUI
import qualified CodeWorld.CanvasM as CM
import CodeWorld.CanvasM (CanvasM, runCanvasM)
import CodeWorld.Color
import CodeWorld.Event
import CodeWorld.Picture
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Char (chr)
import Data.List (find, zip4, intercalate)
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
import Data.Monoid
import Data.Serialize
import Data.Serialize.Text
import qualified Data.Text as T
import Data.Text (Text, pack, singleton)
import qualified Debug.Trace
import GHC.Fingerprint.Type
import GHC.Generics
import GHC.Prim
import GHC.Stack
import GHC.StaticPtr
import Numeric (showFFloatAlt)
import System.Environment
import System.IO
import System.IO.Unsafe
import System.Mem.StableName
import System.Random
import Text.Printf
import Text.Read

#ifdef ghcjs_HOST_OS

import CodeWorld.Message
import CodeWorld.Prediction
import qualified Control.Monad.Trans.State as State
import Data.Hashable
import Data.IORef
import qualified Data.JSString
import Data.JSString.Text
import Data.Word
import GHCJS.Concurrent (withoutPreemption)
import GHCJS.DOM
import qualified GHCJS.DOM.ClientRect as ClientRect
import GHCJS.DOM.Document
import GHCJS.DOM.Element
import GHCJS.DOM.EventM
import GHCJS.DOM.GlobalEventHandlers hiding (error)
import GHCJS.DOM.MouseEvent
import GHCJS.DOM.NonElementParentNode
import GHCJS.DOM.Types (Element, unElement)
import qualified GHCJS.DOM.Window as Window
import GHCJS.Foreign
import GHCJS.Foreign.Callback
import GHCJS.Marshal
import GHCJS.Marshal.Pure
import GHCJS.Types
import qualified JavaScript.Array as Array
import JavaScript.Object
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 Unsafe.Coerce

#else

import Data.Time.Clock
import qualified Graphics.Blank as Canvas
import Graphics.Blank (Canvas)
import Text.Printf

#endif

--------------------------------------------------------------------------------
-- The common interface, provided by both implementations below.
-- | Draws a 'Picture'.  This is the simplest CodeWorld entry point.
drawingOf :: Picture  -- ^ The picture to show on the screen.
          -> IO ()

-- | Shows an animation, with a picture for each time given by the parameter.
animationOf :: (Double -> Picture)  -- ^ A function that produces animation
                                    --   frames, given the time in seconds.
            -> IO ()

-- | Runs an interactive CodeWorld program that responds to events.  Activities
-- can interact with the user, change over time, and remember information about
-- the past.
activityOf
  :: world                       -- ^ The initial state of the interaction.
  -> (Event -> world -> world)   -- ^ The event handling function, which updates
                                 --   the state given an event.
  -> (world -> Picture)          -- ^ The visualization function, which converts
                                 --   the state into a picture to display.
  -> IO ()

-- | Runs an interactive CodeWorld program in debugging mode.  In this mode,
-- the program gets controls to pause and manipulate time, and even go back in
-- time to look at past states.
debugActivityOf
  :: world                       -- ^ The initial state of the interaction.
  -> (Event -> world -> world)   -- ^ The event handling function, which updates
                                 --   the state given an event.
  -> (world -> Picture)          -- ^ The visualization function, which converts
                                 --   the state into a picture to display.
  -> IO ()

-- | Runs an interactive multi-user CodeWorld program that is joined by several
-- participants over the internet.
groupActivityOf
  :: Int  -- ^ The number of participants to expect.  The participants will be
          -- ^ numbered starting at 0.
  -> StaticPtr (StdGen -> world)
          -- ^ The initial state of the activity.
  -> StaticPtr (Int -> Event -> world -> world)
          -- ^ The event handling function, which updates the state given a
          --   participant number and user interface event.
  -> StaticPtr (Int -> world -> Picture)
          -- ^ The visualization function, which converts a participant number
          --   and the state into a picture to display.
  -> IO ()

-- | A version of 'groupActivityOf' that avoids static pointers, and does not
-- check for consistency.
unsafeGroupActivityOf
  :: Int  -- ^ The number of participants to expect.  The participants will be
          -- ^ numbered starting at 0.
  -> (StdGen -> world)
          -- ^ The initial state of the activity.
  -> (Int -> Event -> world -> world)
          -- ^ The event handling function, which updates the state given a
          --   participant number and user interface event.
  -> (Int -> world -> Picture)
          -- ^ The visualization function, which converts a participant number
          --   and the state into a picture to display.
  -> IO ()

-- | Shows a simulation, which is essentially a continuous-time dynamical
-- system described by an initial value and step function.
simulationOf
  :: world                       -- ^ The initial state of the simulation.
  -> (Double -> world -> world)  -- ^ The time step function, which advances
                                 --   the state given the time difference.
  -> (world -> Picture)          -- ^ The visualization function, which converts
                                 --   the state into a picture to display.
  -> IO ()

debugSimulationOf
  :: world                       -- ^ The initial state of the simulation.
  -> (Double -> world -> world)  -- ^ The time step function, which advances
                                 --   the state given the time difference.
  -> (world -> Picture)          -- ^ The visualization function, which converts
                                 --   the state into a picture to display.
  -> 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                       -- ^ The initial state of the interaction.
  -> (Double -> world -> world)  -- ^ The time step function, which advances
                                 --   the state given the time difference.
  -> (Event -> world -> world)   -- ^ The event handling function, which updates
                                 --   the state given a user interface event.
  -> (world -> Picture)          -- ^ The visualization function, which converts
                                 --   the state into a picture to display.
  -> IO ()

debugInteractionOf
  :: world                       -- ^ The initial state of the interaction.
  -> (Double -> world -> world)  -- ^ The time step function, which advances
                                 --   the state given the time difference.
  -> (Event -> world -> world)   -- ^ The event handling function, which updates
                                 --   the state given a user interface event.
  -> (world -> Picture)          -- ^ The visualization function, which converts
                                 --   the state into a picture to display.
  -> IO ()

-- | Runs an interactive multi-user CodeWorld program, involving multiple
-- participants over the internet.
collaborationOf
  :: Int  -- ^ The number of participants to expect.  The participants will be
          -- ^ numbered starting at 0.
  -> StaticPtr (StdGen -> world)
          -- ^ The initial state of the collaboration.
  -> StaticPtr (Double -> world -> world)
          -- ^ The time step function, which advances the state given the time
          --   difference.
  -> StaticPtr (Int -> Event -> world -> world)
          -- ^ The event handling function, which updates the state given a
          --   participant number and user interface event.
  -> StaticPtr (Int -> world -> Picture)
          -- ^ The visualization function, which converts a participant number
          --   and the state into a picture to display.
  -> IO ()

-- | A version of 'collaborationOf' that avoids static pointers, and does not
-- check for consistent parameters.
unsafeCollaborationOf
  :: Int  -- ^ The number of participants to expect.  The participants will be
          -- ^ numbered starting at 0.
  -> (StdGen -> world)
          -- ^ The initial state of the collaboration.
  -> (Double -> world -> world)
          -- ^ The time step function, which advances the state given the time
          --   difference.
  -> (Int -> Event -> world -> world)
          -- ^ The event handling function, which updates the state given a
          --   participant number and user interface event.
  -> (Int -> world -> Picture)
          -- ^ The visualization function, which converts a participant number
          --   and the state into a picture to display.
  -> 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

--------------------------------------------------------------------------------
-- A Drawing is an intermediate and simpler representation of a Picture, suitable
-- for drawing. A drawing does not contain unnecessary metadata like CallStacks.
-- The drawer is specific to the platform.
data Drawing
    = Shape Drawer
    | Transformation (DrawState -> DrawState)
                     Drawing
    | Drawings [Drawing]

#if MIN_VERSION_base(4,11,0)

instance Semigroup Drawing where
    a <> Drawings bs = Drawings (a : bs)
    a <> b           = Drawings [a, b]

#endif

instance Monoid Drawing where
    mempty = Drawings []
    mappend a (Drawings bs) = Drawings (a : bs)
    mappend a b = Drawings [a, b]
    mconcat = Drawings

-- A DrawState is 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)

-- A NodeId a unique id for each node in a Picture of Drawing, chosen by the order
-- the node appears in DFS. When a Picture is converted to a drawing the NodeId's of
-- corresponding nodes are shared. Always >=0.
type NodeId = Int

pictureToDrawing :: Picture -> Drawing
pictureToDrawing (SolidClosedCurve _ pts) = Shape $ polygonDrawer pts True
pictureToDrawing (SolidPolygon _ pts) = Shape $ polygonDrawer pts False
pictureToDrawing (Polygon _ pts) = Shape $ pathDrawer pts 0 True False
pictureToDrawing (ThickPolygon _ pts w) = Shape $ pathDrawer pts w True False
pictureToDrawing (Rectangle _ w h) = Shape $ pathDrawer (rectangleVertices w h) 0 True False
pictureToDrawing (SolidRectangle _ w h) = Shape $ polygonDrawer (rectangleVertices w h) False
pictureToDrawing (ThickRectangle _ lw w h) = Shape $ pathDrawer (rectangleVertices w h) lw True False
pictureToDrawing (ClosedCurve _ pts) = Shape $ pathDrawer pts 0 True True
pictureToDrawing (ThickClosedCurve _ pts w) = Shape $ pathDrawer pts w True True
pictureToDrawing (Circle _ r) = Shape $ arcDrawer 0 (2 * pi) r 0
pictureToDrawing (SolidCircle _ r) = Shape $ sectorDrawer 0 (2 * pi) r
pictureToDrawing (ThickCircle _ lw r) = Shape $ arcDrawer 0 (2 * pi) r lw
pictureToDrawing (Polyline _ pts) = Shape $ pathDrawer pts 0 False False
pictureToDrawing (ThickPolyline _ pts w) = Shape $ pathDrawer pts w False False
pictureToDrawing (Curve _ pts) = Shape $ pathDrawer pts 0 False True
pictureToDrawing (ThickCurve _ pts w) = Shape $ pathDrawer pts w False True
pictureToDrawing (Sector _ b e r) = Shape $ sectorDrawer b e r
pictureToDrawing (Arc _ b e r) = Shape $ arcDrawer b e r 0
pictureToDrawing (ThickArc _ b e r w) = Shape $ arcDrawer b e r w
pictureToDrawing (Lettering _ txt) = Shape $ textDrawer Plain Serif txt
pictureToDrawing (Blank _) = Drawings $ []
pictureToDrawing (StyledLettering _ sty fnt txt) = Shape $ textDrawer sty fnt txt
pictureToDrawing (Logo _) = Shape $ logoDrawer
pictureToDrawing (CoordinatePlane _) = Shape $ coordinatePlaneDrawer
pictureToDrawing (Color _ col p) =
    Transformation (setColorDS col) $ pictureToDrawing p
pictureToDrawing (Translate _ x y p) =
    Transformation (translateDS x y) $ pictureToDrawing p
pictureToDrawing (Scale _ x y p) =
    Transformation (scaleDS x y) $ pictureToDrawing p
pictureToDrawing (Dilate _ k p) =
    Transformation (scaleDS k k) $ pictureToDrawing p
pictureToDrawing (Rotate _ r p) =
    Transformation (rotateDS r) $ pictureToDrawing p
pictureToDrawing (Pictures _ ps) = Drawings $ pictureToDrawing <$> ps
pictureToDrawing (PictureAnd _ ps) = Drawings $ pictureToDrawing <$> ps

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 col@(RGBA _ _ _ 0) (a, b, c, d, e, f, _) =
    (a, b, c, d, e, f, Just col)
setColorDS (RGBA _ _ _ alpha1) (a, b, c, d, e, f, Just (RGBA rr gg bb alpha2)) =
    (a, b, c, d, e, f, Just (RGBA rr gg bb (alpha1 * alpha2)))

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

polygonDrawer :: [Point] -> Bool -> Drawer
pathDrawer :: [Point] -> Double -> Bool -> Bool -> Drawer
sectorDrawer :: Double -> Double -> Double -> Drawer
arcDrawer :: Double -> Double -> Double -> Double -> Drawer
textDrawer :: TextStyle -> Font -> Text -> Drawer
logoDrawer :: Drawer
coordinatePlaneDrawer :: Drawer
coordinatePlaneDrawing :: Drawing
coordinatePlaneDrawing = pictureToDrawing $ axes <> numbers <> guidelines
  where
    xline y = thickPolyline 0.01 [(-10, y), (10, y)]
    xaxis = thickPolyline 0.03 [(-10, 0), (10, 0)]
    axes = xaxis <> rotated (pi / 2) xaxis
    xguidelines = pictures [xline k | k <- [-10,-9 .. 10]]
    guidelines = xguidelines <> rotated (pi / 2) xguidelines
    numbers = xnumbers <> ynumbers
    xnumbers =
        pictures
            [ translated
                (fromIntegral k)
                0.3
                (scaled 0.5 0.5 (lettering (pack (show k))))
            | k <- [-9,-8 .. 9]
            , k /= 0
            ]
    ynumbers =
        pictures
            [ translated
                0.3
                (fromIntegral k)
                (scaled 0.5 0.5 (lettering (pack (show k))))
            | k <- [-9,-8 .. 9]
            , k /= 0
            ]

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

applyColor :: DrawState -> CanvasM ()
applyColor ds =
    case getColorDS ds of
        Nothing -> do
            CM.strokeColor 0 0 0 1
            CM.fillColor 0 0 0 1
        Just (RGBA r g b a) -> do
            CM.strokeColor
                (round $ r * 255)
                (round $ g * 255)
                (round $ b * 255)
                a
            CM.fillColor
                (round $ r * 255)
                (round $ g * 255)
                (round $ b * 255)
                a

type Drawer = DrawState -> DrawMethods

data DrawMethods = DrawMethods
    { drawShape :: CanvasM ()
    , shapeContains :: CanvasM Bool
    }

polygonDrawer ps smooth ds =
    DrawMethods
    { drawShape = do
          trace
          applyColor ds
          CM.fill
    , shapeContains = do
          trace
          CM.isPointInPath (0, 0)
    }
  where
    trace = withDS ds $ followPath ps True smooth

pathDrawer ps w closed smooth ds =
    DrawMethods
    { drawShape = drawFigure ds w $ followPath ps closed smooth
    , shapeContains =
          do let width =
                     if w == 0
                         then 0.3
                         else w
             drawFigure ds width $ followPath ps closed smooth
             CM.isPointInStroke (0, 0)
    }

sectorDrawer b e r ds =
    DrawMethods
    { drawShape = do
          trace
          applyColor ds
          CM.fill
    , shapeContains = do
          trace
          CM.isPointInPath (0, 0)
    }
  where
    trace =
        withDS ds $ do
            CM.arc 0 0 (25 * abs r) b e (b > e)
            CM.lineTo (0, 0)

arcDrawer b e r w ds =
    DrawMethods
    { drawShape =
          drawFigure ds w $ CM.arc 0 0 (25 * abs r) b e (b > e)
    , shapeContains =
          do let width =
                     if w == 0
                         then 0.3
                         else w
             CM.lineWidth (width * 25)
             drawFigure ds width $
                 CM.arc 0 0 (25 * abs r) b e (b > e)
             CM.isPointInStroke (0, 0)
    }

textDrawer sty fnt txt ds =
    DrawMethods
    { drawShape =
          withDS ds $ do
              CM.scale 1 (-1)
              applyColor ds
              CM.font (fontString sty fnt)
              CM.fillText txt (0, 0)
    , shapeContains =
          do CM.font (fontString sty fnt)
             width <- CM.measureText txt
             let height = 25 -- constant, defined in fontString
             withDS ds $
                 CM.rect ((-0.5) * width) ((-0.5) * height) width height
             CM.isPointInPath (0, 0)
    }

logoDrawer ds =
    DrawMethods
    { drawShape =
          withDS ds $ do
              CM.scale 1 (-1)
              drawCodeWorldLogo ds (-221) (-91) 442 182
    , shapeContains =
          withDS ds $ do
              CM.rect (-221) (-91) 442 182
              CM.isPointInPath (0, 0)
    }

coordinatePlaneDrawer ds =
    DrawMethods
    { drawShape = drawDrawing ds coordinatePlaneDrawing
    , shapeContains = fst <$> findTopShape ds coordinatePlaneDrawing
    }

followPath :: [Point] -> Bool -> Bool -> CanvasM ()
followPath [] closed _ = return ()
followPath [p1] closed _ = return ()
followPath ((sx, sy):ps) closed False = do
    CM.moveTo (25 * sx, 25 * sy)
    forM_ ps $ \(x, y) -> CM.lineTo (25 * x, 25 * y)
    when closed $ CM.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
    CM.moveTo (25 * x1, 25 * y1)
    CM.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)) -> do
        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
        CM.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
    CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x3, 25 * y3)
followPath ps@(_:(sx, sy):_) True True = do
    CM.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)) -> do
        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
        CM.bezierCurveTo
            (25 * cx1, 25 * cy1)
            (25 * cx2, 25 * cy2)
            (25 * x3,  25 * y3)
    CM.closePath

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

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 <> "\""

drawDrawing :: DrawState -> Drawing -> CanvasM ()
drawDrawing ds (Shape shape) = drawShape $ shape ds
drawDrawing ds (Transformation f d) = drawDrawing (f ds) d
drawDrawing ds (Drawings drs) = mapM_ (drawDrawing ds) (reverse drs)

findTopShape :: DrawState -> Drawing -> CanvasM (Bool, Int)
findTopShape ds (Shape drawer) = do
    contained <- shapeContains $ drawer ds
    case contained of
        True -> return (True, 0)
        False -> return (False, 1)
findTopShape ds (Transformation f d) =
    fmap (+ 1) <$> findTopShape (f ds) d
findTopShape ds (Drawings []) = return (False, 1)
findTopShape ds (Drawings (dr:drs)) = do
    (found, count) <- findTopShape ds dr
    case found of
        True -> return (True, count + 1)
        False -> fmap (+ count) <$> findTopShape ds (Drawings drs)

#ifdef ghcjs_HOST_OS

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

-- Debug Mode logic
inspect ::
       IO Picture -> (Bool -> IO ()) -> (Bool -> Maybe NodeId -> IO ()) -> IO ()
inspect getPic handleActive highlight =
    initDebugMode (handlePointRequest getPic) handleActive getPic highlight

handlePointRequest :: IO Picture -> Point -> IO (Maybe NodeId)
handlePointRequest getPic pt = do
    drawing <- pictureToDrawing <$> getPic
    findTopShapeFromPoint pt drawing

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

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

foreign import javascript unsafe "showCanvas()"
    showCanvas :: IO ()

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

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

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

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

nextFrame :: IO Double
nextFrame = waitForAnimationFrame >> getTime

drawCodeWorldLogo ::
       DrawState -> Int -> Int -> Int -> Int -> CanvasM ()
drawCodeWorldLogo ds x y w h = do
    Just doc <- liftIO $ currentDocument
    Just canvas <- liftIO $ getElementById doc ("cwlogo" :: JSString)
    case getColorDS ds of
        Nothing -> CM.drawImage (canvasFromElement canvas) x y w h
        Just (RGBA r g b a)
            -- This is a tough case.  The best we can do is to allocate an
            -- offscreen buffer as a temporary.
         -> do
            (img, _) <- CM.newImage w h $ do
                applyColor ds
                CM.fillRect 0 0 (fromIntegral w) (fromIntegral h)
                CM.globalCompositeOperation "destination-in"
                CM.drawImage (canvasFromElement canvas) 0 0 w h
            CM.drawImage img x y w h

initDebugMode ::
       (Point -> IO (Maybe NodeId))
    -> (Bool -> IO ())
    -> IO Picture
    -> (Bool -> Maybe NodeId -> IO ())
    -> IO ()
initDebugMode getnode setactive getpicture highlight = do
    getnodeCB <-
        syncCallback1' $ \pointJS -> do
            let obj = unsafeCoerce pointJS
            x <- pFromJSVal <$> getProp "x" obj
            y <- pFromJSVal <$> getProp "y" obj
            pToJSVal . fromMaybe (-1) <$> getnode (x, y)
    setactiveCB <- syncCallback1 ContinueAsync $ setactive . pFromJSVal
    getpictureCB <- syncCallback' $ getpicture >>= picToObj
    highlightCB <-
        syncCallback2 ContinueAsync $ \t n ->
            let select = pFromJSVal t
                node =
                    case ((pFromJSVal n) :: Int) < 0 of
                        True -> Nothing
                        False -> Just $ pFromJSVal n
            in highlight select node
    drawCB <-
        syncCallback2 ContinueAsync $ \c n -> do
            let canvas = unsafeCoerce c :: Element
                nodeId = pFromJSVal n
            drawing <- pictureToDrawing <$> getpicture
            let node = fromMaybe (Drawings []) $ fst <$> getDrawNode nodeId drawing
            offscreenCanvas <- Canvas.create 500 500
            setCanvasSize canvas canvas
            setCanvasSize (elementFromCanvas offscreenCanvas) canvas
            screen <- getCodeWorldContext (canvasFromElement canvas)
            rect <- getBoundingClientRect canvas
            withScreen (elementFromCanvas offscreenCanvas) rect $
                drawFrame (node <> coordinatePlaneDrawing)
            rect <- getBoundingClientRect canvas
            cw <- ClientRect.getWidth rect
            ch <- ClientRect.getHeight rect
            canvasDrawImage
                screen
                (elementFromCanvas offscreenCanvas)
                0
                0
                (round cw)
                (round ch)
    js_initDebugMode getnodeCB setactiveCB getpictureCB highlightCB drawCB

foreign import javascript unsafe "initDebugMode($1,$2,$3,$4,$5)"
    js_initDebugMode :: Callback (JSVal -> IO JSVal)
                     -> Callback (JSVal -> IO ())
                     -> Callback (IO JSVal)
                     -> Callback (JSVal -> JSVal -> IO ())
                     -> Callback (JSVal -> JSVal -> IO ())
                     -> IO ()

picToObj :: Picture -> IO JSVal
picToObj = fmap fst . flip State.runStateT 0 . picToObj'

picToObj' :: Picture -> State.StateT Int IO JSVal
picToObj' pic = objToJSVal <$> case pic of
    Pictures _ ps -> mkNodeWithChildren ps
    PictureAnd _ ps -> mkNodeWithChildren ps
    Color _ _ p -> mkNodeWithChild p
    Translate _ _ _ p -> mkNodeWithChild p
    Scale _ _ _ p -> mkNodeWithChild p
    Dilate _ _ p -> mkNodeWithChild p
    Rotate _ _ p -> mkNodeWithChild p
    _ -> mkSimpleNode
  where
    mkSimpleNode :: State.StateT Int IO Object
    mkSimpleNode = do
        obj <- liftIO create
        id <- do
            currentId <- State.get
            State.put (currentId + 1)
            return currentId
        liftIO $ do
            setProp "id" (pToJSVal id) obj
            setProp "name" (pToJSVal $ (trim 80 . describePicture) pic) obj
            case getPictureSrcLoc pic of
                Just loc -> do
                    setProp "startLine" (pToJSVal $ srcLocStartLine loc) obj
                    setProp "startCol" (pToJSVal $ srcLocStartCol loc) obj
                    setProp "endLine" (pToJSVal $ srcLocEndLine loc) obj
                    setProp "endCol" (pToJSVal $ srcLocEndCol loc) obj
                Nothing -> return ()
        return obj

    mkNodeWithChild :: Picture -> State.StateT Int IO Object
    mkNodeWithChild p = do
        obj <- mkSimpleNode
        subPic <- picToObj' p
        liftIO $ setProp "picture" subPic obj
        return obj

    mkNodeWithChildren :: [Picture] -> State.StateT Int IO Object
    mkNodeWithChildren ps = do
        obj <- mkSimpleNode
        arr <- liftIO $ Array.create
        mapM_ (\p -> picToObj' p >>= liftIO . flip Array.push arr) ps
        liftIO $ setProp "pictures" (unsafeCoerce arr) obj
        return obj

    objToJSVal = unsafeCoerce :: Object -> JSVal

trim :: Int -> String -> String
trim x y = let mid = (x - 2) `div` 2
    in case x >= (length y) of
                True -> y :: String
                False -> take mid y ++ ".." ++ (reverse $ take mid $ reverse y)

foreign import javascript unsafe "/\\bmode=haskell\\b/.test(location.search)"
    haskellMode :: Bool

showFloat :: Double -> String
showFloat x
  | haskellMode && x < 0 = "(" ++ result ++ ")"
  | otherwise = result
  where result = stripZeros (showFFloatAlt (Just 4) x "")
        stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse

showPoints :: [Point] -> String
showPoints pts =
    "[" ++
    intercalate ", " [
        "(" ++ showFloat x ++ ", " ++ showFloat y ++ ")"
        | (x, y) <- pts
    ] ++
    "]"

showColor :: Color -> String
showColor c@(RGBA r g b a)
  | c == black = "black"
  | c == white = "white"
  | c == red = "red"
  | c == green = "green"
  | c == blue = "blue"
  | c == yellow = "yellow"
  | c == orange = "orange"
  | c == brown = "brown"
  | c == pink = "pink"
  | c == purple = "purple"
  | c == gray = "gray"
  | haskellMode, a == 1 = printf "(RGB %s %s %s)" (showFloat r) (showFloat g) (showFloat b)
  | a == 1 = printf "RGB(%s, %s, %s)" (showFloat r) (showFloat g) (showFloat b)
  | haskellMode = printf "(RGBA %s %s %s %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a)
  | otherwise = printf "RGBA(%s, %s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a)

describePicture :: Picture -> String
describePicture (Rectangle _ w h)
  | haskellMode = printf "rectangle %s %s" (showFloat w) (showFloat h)
  | otherwise   = printf "rectangle(%s, %s)" (showFloat w) (showFloat h)
describePicture (SolidRectangle _ w h)
  | haskellMode = printf "solidRectangle %s %s" (showFloat w) (showFloat h)
  | otherwise   = printf "solidRectangle(%s, %s)" (showFloat w) (showFloat h)
describePicture (ThickRectangle _ lw w h)
  | haskellMode = printf "thickRectangle %s %s %s" (showFloat lw) (showFloat w) (showFloat h)
  | otherwise   = printf "thickRectangle(%s, %s, %s)" (showFloat w) (showFloat h) (showFloat lw)
describePicture (Circle _ r)
  | haskellMode = printf "circle %s" (showFloat r)
  | otherwise   = printf "circle(%s)" (showFloat r)
describePicture (SolidCircle _ r)
  | haskellMode = printf "solidCircle %s" (showFloat r)
  | otherwise   = printf "solidCircle(%s)" (showFloat r)
describePicture (ThickCircle _ lw r)
  | haskellMode = printf "thickCircle %s %s" (showFloat lw) (showFloat r)
  | otherwise   = printf "thickCircle(%s, %s)" (showFloat r) (showFloat lw)
describePicture (SolidPolygon _ pts)
  | haskellMode = printf "solidPolygon %s" (showPoints pts)
  | otherwise   = printf "solidPolygon(%s)" (showPoints pts)
describePicture (SolidClosedCurve _ pts)
  | haskellMode = printf "solidClosedCurve %s" (showPoints pts)
  | otherwise   = printf "solidClosedCurve(%s)" (showPoints pts)
describePicture (Polygon _ pts)
  | haskellMode = printf "polygon %s" (showPoints pts)
  | otherwise   = printf "polygon(%s)" (showPoints pts)
describePicture (ThickPolygon _ pts w)
  | haskellMode = printf "thickPolygon %s %s" (showFloat w) (showPoints pts)
  | otherwise   = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat w)
describePicture (ClosedCurve _ pts)
  | haskellMode = printf "closedCurve %s" (showPoints pts)
  | otherwise   = printf "closedCurve(%s)" (showPoints pts)
describePicture (ThickClosedCurve _ pts w)
  | haskellMode = printf "thickClosedCurve %s %s" (showFloat w) (showPoints pts)
  | otherwise   = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat w)
describePicture (Polyline _ pts)
  | haskellMode = printf "polyline %s" (showPoints pts)
  | otherwise   = printf "polyline(%s)" (showPoints pts)
describePicture (ThickPolyline _ pts w)
  | haskellMode = printf "thickPolyline %s %s" (showFloat w) (showPoints pts)
  | otherwise   = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat w)
describePicture (Curve _ pts)
  | haskellMode = printf "curve %s" (showPoints pts)
  | otherwise   = printf "curve(%s)" (showPoints pts)
describePicture (ThickCurve _ pts w)
  | haskellMode = printf "thickCurve %s %s" (showFloat w) (showPoints pts)
  | otherwise   = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat w)
describePicture (Sector _ b e r)
  | haskellMode = printf "sector %s %s %s" (showFloat b) (showFloat e) (showFloat r)
  | otherwise   = printf "sector(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r)
describePicture (Arc _ b e r)
  | haskellMode = printf "arc %s %s %s" (showFloat b) (showFloat e) (showFloat r)
  | otherwise   = printf "arc(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r)
describePicture (ThickArc _ b e r w)
  | haskellMode = printf "thickArc %s %s %s %s" (showFloat w) (showFloat b) (showFloat e) (showFloat r)
  | otherwise   = printf "thickArc(%s°, %s°, %s, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) (showFloat w)
describePicture (Lettering _ txt)
  | haskellMode = printf "lettering %s" (show txt)
  | otherwise   = printf "lettering(%s)" (show txt)
describePicture (Blank _) = "blank"
describePicture (StyledLettering _ style font txt)
  | haskellMode = printf "styledLettering %s %s %s" (showsPrec 10 style "") (showsPrec 10 font "") (show txt)
  | otherwise   = printf "styledLettering(%s, %s, %s)" (show txt) (show font) (show style)
describePicture (Color _ c _)
  | haskellMode = printf "colored %s" (showColor c)
  | otherwise   = printf "colored(..., %s)" (showColor c)
describePicture (Translate _ x y _)
  | haskellMode = printf "translated %s %s" (showFloat x) (showFloat y)
  | otherwise   = printf "translated(..., %s, %s)" (showFloat x) (showFloat y)
describePicture (Scale _ x y _)
  | haskellMode = printf "scaled %s %s" (showFloat x) (showFloat y)
  | otherwise   = printf "scaled(..., %s, %s)" (showFloat x) (showFloat y)
describePicture (Rotate _ angle _)
  | haskellMode = printf "rotated %s" (showFloat angle)
  | otherwise   = printf "rotated(..., %s°)" (showFloat (180 * angle / pi))
describePicture (Dilate _ k _)
  | haskellMode = printf "dilated %s" (showFloat k)
  | otherwise   = printf "dilated(..., %s)" (showFloat k)
describePicture (Logo _) = "codeWorldLogo"
describePicture (CoordinatePlane _) = "coordinatePlane"
describePicture (Pictures _ _)
  | haskellMode = "pictures"
  | otherwise   = "pictures(...)"
describePicture (PictureAnd _ _)
  | haskellMode = "(&)"
  | otherwise   = "... & ..."

getPictureSrcLoc :: Picture -> Maybe SrcLoc
getPictureSrcLoc (SolidPolygon loc _) = loc
getPictureSrcLoc (SolidClosedCurve loc _) = loc
getPictureSrcLoc (Polygon loc _) = loc
getPictureSrcLoc (ThickPolygon loc _ _) = loc
getPictureSrcLoc (Rectangle loc _ _) = loc
getPictureSrcLoc (SolidRectangle loc _ _) = loc
getPictureSrcLoc (ThickRectangle loc _ _ _) = loc
getPictureSrcLoc (ClosedCurve loc _) = loc
getPictureSrcLoc (ThickClosedCurve loc _ _) = loc
getPictureSrcLoc (Circle loc _) = loc
getPictureSrcLoc (SolidCircle loc _) = loc
getPictureSrcLoc (ThickCircle loc _ _) = loc
getPictureSrcLoc (Polyline loc _) = loc
getPictureSrcLoc (ThickPolyline loc _ _) = loc
getPictureSrcLoc (Curve loc _) = loc
getPictureSrcLoc (ThickCurve loc _ _) = loc
getPictureSrcLoc (Sector loc _ _ _) = loc
getPictureSrcLoc (Arc loc _ _ _) = loc
getPictureSrcLoc (ThickArc loc _ _ _ _) = loc
getPictureSrcLoc (Lettering loc _) = loc
getPictureSrcLoc (Blank loc) = loc
getPictureSrcLoc (StyledLettering loc _ _ _) = loc
getPictureSrcLoc (Color loc _ _) = loc
getPictureSrcLoc (Translate loc _ _ _) = loc
getPictureSrcLoc (Scale loc _ _ _) = loc
getPictureSrcLoc (Dilate loc _ _) = loc
getPictureSrcLoc (Rotate loc _ _) = loc
getPictureSrcLoc (Logo loc) = loc
getPictureSrcLoc (CoordinatePlane loc) = loc
getPictureSrcLoc (Pictures loc _) = loc
getPictureSrcLoc (PictureAnd loc _) = loc

-- If a picture is found, the result will include an array of the base picture
-- and all transformations.
findTopShapeFromPoint :: Point -> Drawing -> IO (Maybe NodeId)
findTopShapeFromPoint (x, y) pic = do
    buf <- Canvas.create 500 500
    ctx <- Canvas.getContext buf
    (found, node) <- runCanvasM ctx $
        findTopShape (translateDS (10 - x / 25) (y / 25 - 10) initialDS)
                     pic
    case found of
        True -> return $ Just node
        False -> return Nothing

drawFrame :: Drawing -> CanvasM ()
drawFrame drawing = do
    CM.fillColor 255 255 255 1
    CM.fillRect (-250) (-250) 500 500
    drawDrawing initialDS drawing

withScreen :: Element -> ClientRect.ClientRect -> CanvasM a -> IO a
withScreen canvas rect action = do
    cw <- ClientRect.getWidth rect
    ch <- ClientRect.getHeight rect
    ctx <- getCodeWorldContext (canvasFromElement canvas)
    runCanvasM ctx $ CM.saveRestore $ do
        CM.translate (realToFrac cw / 2) (realToFrac ch / 2)
        CM.scale (realToFrac cw / 500) (-realToFrac ch / 500)
        CM.lineWidth 0
        CM.textCenter
        CM.textMiddle
        action

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))

#else

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

drawCodeWorldLogo ::
       DrawState -> Int -> Int -> Int -> Int -> CanvasM ()
drawCodeWorldLogo ds x y w h = return ()

setupScreenContext :: (Int, Int) -> Canvas ()
setupScreenContext (cw, ch)
    -- blank before transformation (canvas might be non-sqare)
 = do
    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

#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"
        47 -> "Help"
        91 -> "OS"
        92 -> "OS"
        93 -> "ContextMenu"
        106 -> "*"
        107 -> "+"
        108 -> ","
        109 -> "-"
        110 -> "."
        111 -> "/"
        144 -> "NumLock"
        145 -> "ScrollLock"
        173 -> "-"
        186 -> ";"
        187 -> "="
        188 -> ","
        189 -> "-"
        190 -> "."
        191 -> "/"
        192 -> "`"
        193 -> "IntlRo"
        194 -> ","
        219 -> "["
        220 -> "\\"
        221 -> "]"
        222 -> "'"
        225 -> "AltGraph"
        255 -> "IntlYen"
        _ -> "Unknown:" <> fromNum n
  where
    fromAscii n = singleton (chr (fromIntegral n))
    fromNum n = pack (show (fromIntegral n))

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

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

modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool
modifyMVarIfDifferent var f =
    modifyMVar var $ \s0 -> do
        case ifDifferent f s0 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 }
    | SteplessToken { tokenDeployHash :: Text
                    , tokenNumPlayers :: Int
                    , tokenInitial :: StaticKey
                    , tokenEvent :: StaticKey
                    , tokenDraw :: StaticKey }
    | PartialToken { tokenDeployHash :: Text }
    | NoToken
    deriving (Generic)

deriving instance Generic Fingerprint

instance Serialize Fingerprint

instance Serialize GameToken

#ifdef ghcjs_HOST_OS

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

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)

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
        pos <- getMousePos canvas
        liftIO $ handler (PointerPress pos)
    on window mouseUp $ do
        pos <- getMousePos canvas
        liftIO $ handler (PointerRelease pos)
    on window mouseMove $ do
        pos <- getMousePos canvas
        liftIO $ handler (PointerMovement 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
            case ifDifferent eventFun gameState0 of
                Nothing -> 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"
                _ -> error "Unrecognized protocol"
    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

foreign import javascript unsafe "cw$deterministic_math();"
    enableDeterministicMath :: IO ()

runGame ::
       GameToken
    -> Int
    -> (StdGen -> s)
    -> (Double -> s -> s)
    -> (Int -> Event -> s -> s)
    -> (Int -> s -> Picture)
    -> IO ()
runGame token numPlayers initial stepHandler eventHandler drawHandler = do
    enableDeterministicMath
    let fullStepHandler dt = stepHandler dt . eventHandler (-1) (TimePassing dt)
    showCanvas
    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
            fullStepHandler
            eventHandler
            token
            currentGameState
    screen <- getCodeWorldContext (canvasFromElement canvas)
    let go t0 lastFrame = do
            gs <- readMVar currentGameState
            let pic = gameDraw fullStepHandler drawHandler gs t0
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ do
                rect <- getBoundingClientRect canvas
                withScreen (elementFromCanvas offscreenCanvas) rect $
                    drawFrame (pictureToDrawing pic)
                rect <- getBoundingClientRect canvas
                cw <- ClientRect.getWidth rect
                ch <- ClientRect.getHeight rect
                when (cw > 0 && ch > 0) $ canvasDrawImage
                    screen
                    (elementFromCanvas offscreenCanvas)
                    0
                    0
                    (round cw)
                    (round ch)
            t1 <- nextFrame
            modifyMVar_ currentGameState $ return . gameStep fullStepHandler t1
            go t1 picFrame
    t0 <- getTime
    nullFrame <- makeStableName undefined
    initialStateName <- makeStableName $! initialGameState
    go t0 nullFrame

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

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

foreign import javascript "console.log($1);"
    js_debugLog :: JSString -> IO ()

debugLog :: String -> IO ()
debugLog = js_debugLog . Data.JSString.pack

propagateErrors :: ThreadId -> IO () -> IO ()
propagateErrors tid action = action `catch` \ (e :: SomeException) -> throwTo tid e

run :: s
    -> (Double -> s -> s)
    -> (e -> s -> s)
    -> (s -> Drawing)
    -> (Double -> e)
    -> IO (e -> IO (), IO s)
run initial stepHandler eventHandler drawHandler injectTime = do
    let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt)
    showCanvas
    Just window <- currentWindow
    Just doc <- currentDocument
    Just canvas <- getElementById doc ("screen" :: JSString)
    offscreenCanvas <- Canvas.create 500 500
    setCanvasSize canvas canvas
    setCanvasSize (elementFromCanvas offscreenCanvas) canvas
    needsRedraw <- newMVar ()
    on window resize $ void $ liftIO $ do
        setCanvasSize canvas canvas
        setCanvasSize (elementFromCanvas offscreenCanvas) canvas
        tryPutMVar needsRedraw ()
    currentState <- newMVar initial
    eventHappened <- newMVar ()
    screen <- getCodeWorldContext (canvasFromElement canvas)
    let go t0 lastFrame lastStateName needsTime = do
            pic <- drawHandler <$> readMVar currentState
            picFrame <- makeStableName $! pic
            when (picFrame /= lastFrame) $ do
                rect <- getBoundingClientRect canvas
                withScreen (elementFromCanvas offscreenCanvas) rect $
                    drawFrame pic
                rect <- getBoundingClientRect canvas
                cw <- ClientRect.getWidth rect
                ch <- ClientRect.getHeight rect
                when (cw > 0 && ch > 0) $ canvasDrawImage
                    screen
                    (elementFromCanvas offscreenCanvas)
                    0
                    0
                    (round cw)
                    (round ch)
            t1 <-
                if | needsTime ->
                       do t1 <- nextFrame
                          let dt = min (t1 - t0) 0.25
                          modifyMVarIfDifferent currentState (fullStepHandler dt)
                          return t1
                   | otherwise ->
                       do takeMVar eventHappened
                          getTime
            nextState <- readMVar currentState
            nextStateName <- makeStableName $! nextState
            let nextNeedsTime =
                    nextStateName /= lastStateName ||
                    needsTime && not (isUniversallyConstant fullStepHandler nextState)
            nextFrame <- tryTakeMVar needsRedraw >>= \case
                Nothing -> return picFrame
                Just () -> makeStableName undefined
            go t1 nextFrame nextStateName nextNeedsTime
    t0 <- getTime
    nullFrame <- makeStableName undefined
    initialStateName <- makeStableName $! initial
    mainThread <- myThreadId
    drawThread <- forkIO $ propagateErrors mainThread $
        go t0 nullFrame initialStateName True
    let sendEvent event = propagateErrors drawThread $ do
            changed <-
                modifyMVarIfDifferent currentState (eventHandler event)
            when changed $ void $ tryPutMVar eventHappened ()
        getState = readMVar currentState
    return (sendEvent, getState)

data DebugState = DebugState
    { debugStateActive :: Bool
    , shapeHighlighted :: Maybe NodeId
    , shapeSelected :: Maybe NodeId
    }

data DebugEvent
    = DebugStart
    | DebugStop
    | HighlightEvent (Maybe NodeId)
    | SelectEvent (Maybe NodeId)

debugStateInit :: DebugState
debugStateInit = DebugState False Nothing Nothing

updateDebugState :: DebugEvent -> DebugState -> DebugState
updateDebugState DebugStart prev = DebugState True Nothing Nothing
updateDebugState DebugStop prev = DebugState False Nothing Nothing
updateDebugState (HighlightEvent n) prev =
    case debugStateActive prev of
        True -> prev {shapeHighlighted = n}
        False -> DebugState False Nothing Nothing
updateDebugState (SelectEvent n) prev =
    case debugStateActive prev of
        True -> prev {shapeSelected = n}
        False -> DebugState False Nothing Nothing

drawDebugState :: DebugState -> Drawing -> Drawing
drawDebugState state drawing =
    case debugStateActive state of
        True ->
            highlightSelectShape
                (shapeHighlighted state)
                (shapeSelected state)
                drawing
        False -> drawing

-- Utility functions that apply a function in either the left or right half of a
-- tuple.  Crucially, if the function preserves sharing on its side, then the
-- wrapper also preserves sharing.
inLeft :: (a -> a) -> (a, b) -> (a, b)
inLeft f ab = unsafePerformIO $ do
  let (a, b) = ab
  aName <- makeStableName $! a
  let a' = f a
  aName' <- makeStableName $! a'
  return $ if aName == aName' then ab else (a', b)

inRight :: (b -> b) -> (a, b) -> (a, b)
inRight f ab = unsafePerformIO $ do
  let (a, b) = ab
  bName <- makeStableName $! b
  let b' = f b
  bName' <- makeStableName $! b'
  return $ if bName == bName' then ab else (a, b')

foreign import javascript interruptible "window.dummyVar = 0;"
  waitForever :: IO ()

-- Wraps the event and state from run so they can be paused by pressing the Inspect
-- button.
runInspect ::
       (Wrapped s -> [Control s])
    -> s
    -> (Double -> s -> s)
    -> (Event -> s -> s)
    -> (s -> Picture)
    -> IO ()
runInspect controls initial stepHandler eventHandler drawHandler = do
    Just window <- currentWindow
    Just doc <- currentDocument
    Just canvas <- getElementById doc ("screen" :: JSString)
    let initialWrapper = (debugStateInit, wrappedInitial initial)
        stepHandlerWrapper dt wrapper@(debugState, _) =
            case debugStateActive debugState of
                True -> wrapper
                False -> inRight (wrappedStep stepHandler dt) wrapper
        eventHandlerWrapper evt wrapper@(debugState, _) =
            case (debugStateActive debugState, evt) of
                (_, Left debugEvent) ->
                    inLeft (updateDebugState debugEvent) wrapper
                (True, _) -> wrapper
                (_, Right normalEvent) ->
                    inRight (wrappedEvent controls stepHandler eventHandler normalEvent) wrapper
        drawHandlerWrapper (debugState, wrappedState) =
            case debugStateActive debugState of
                True -> drawDebugState debugState $ pictureToDrawing $ drawHandler (state wrappedState)
                False -> pictureToDrawing (wrappedDraw controls drawHandler wrappedState)
        drawPicHandler (debugState, wrappedState) =
            drawHandler $ state wrappedState
    (sendEvent, getState) <-
        run
            initialWrapper
            stepHandlerWrapper
            (\e w -> (eventHandlerWrapper e) w)
            drawHandlerWrapper
            (Right . TimePassing)
    let pauseEvent True = sendEvent $ Left DebugStart
        pauseEvent False = sendEvent $ Left DebugStop
        highlightSelectEvent True n = sendEvent $ Left (HighlightEvent n)
        highlightSelectEvent False n = sendEvent $ Left (SelectEvent n)
    onEvents canvas (sendEvent . Right)
    inspect (drawPicHandler <$> getState) pauseEvent highlightSelectEvent
    waitForever

-- Given a drawing, highlight the first node and select second node. Both recolor
-- the nodes, but highlight also brings the node to the top.
highlightSelectShape :: Maybe NodeId -> Maybe NodeId -> Drawing -> Drawing
highlightSelectShape h s drawing
    | isNothing s =
        fromMaybe drawing $ do
            h' <- h
            hp <- piece h'
            return $ hp <> drawing
    | isNothing h =
        fromMaybe drawing $ do
            s' <- s
            sp <- piece s'
            replaceDrawNode s' sp drawing
    | otherwise =
        fromMaybe drawing $ do
            h' <- h
            s' <- s
            hp <- piece h'
            sp <- piece s'
            replaced <- replaceDrawNode s' sp drawing
            return $ hp <> replaced
  where
    piece n =
        (\(node, ds) -> highlightDrawing ds node) <$> getDrawNode n drawing

highlightDrawing :: DrawState -> Drawing -> Drawing
highlightDrawing (a, b, c, d, e, f, _) drawing =
    Transformation (\_ -> (a, b, c, d, e, f, Just col')) drawing
  where
    col' = RGBA 0 0 0 0.25

getDrawNode :: NodeId -> Drawing -> Maybe (Drawing, DrawState)
getDrawNode n _
    | n < 0 = Nothing
getDrawNode n drawing = either Just (const Nothing) $ go initialDS n drawing
  where
    go ds 0 d = Left (d, ds)
    go ds n (Shape _) = Right (n - 1)
    go ds n (Transformation f dr) = go (f ds) (n - 1) dr
    go ds n (Drawings []) = Right (n - 1)
    go ds n (Drawings (dr:drs)) =
        case go ds (n - 1) dr of
            Left d -> Left d
            Right n -> go ds (n + 1) $ Drawings drs

replaceDrawNode :: NodeId -> Drawing -> Drawing -> Maybe Drawing
replaceDrawNode n _ _
    | n < 0 = Nothing
replaceDrawNode n with drawing = either Just (const Nothing) $ go n drawing
  where
    go :: Int -> Drawing -> Either Drawing Int
    go 0 _ = Left with
    go n (Shape _) = Right (n - 1)
    go n (Transformation f d) = mapLeft (Transformation f) $ go (n - 1) d
    go n (Drawings []) = Right (n - 1)
    go n (Drawings (dr:drs)) =
        case go (n - 1) dr of
            Left d -> Left $ Drawings (d : drs)
            Right m ->
                mapLeft (\(Drawings qs) -> Drawings (dr : qs)) $
                go (m + 1) $ Drawings drs
    mapLeft :: (a -> b) -> Either a c -> Either b c
    mapLeft f = either (Left . f) Right

#else

debugLog :: String -> IO ()
debugLog = putStrLn

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

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 pos <- getMousePos rect <$> ePageXY = Just $ PointerPress pos
    | eType == "mouseup"
    , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerRelease pos
    | eType == "mousemove"
    , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerMovement 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
        forM_ maybeEvent handler

run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()
run initial stepHandler eventHandler drawHandler =
    runBlankCanvas $ \context -> do
        let fullStepHandler dt = stepHandler dt . eventHandler (TimePassing dt)
        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) $
                    Canvas.send context $ do
                        Canvas.with offscreenCanvas $
                            Canvas.saveRestore $ do
                                setupScreenContext rect
                                drawDrawing initialDS (pictureToDrawing 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 . fullStepHandler dt)
                              return t1
                       | otherwise ->
                           do takeMVar eventHappened
                              getCurrentTime
                nextState <- readMVar currentState
                nextStateName <- makeStableName $! nextState
                let nextNeedsTime =
                        nextStateName /= lastStateName ||
                        needsTime && not (isUniversallyConstant fullStepHandler nextState)
                go t1 picFrame nextStateName nextNeedsTime
        t0 <- getCurrentTime
        nullFrame <- makeStableName undefined
        initialStateName <- makeStableName $! initial
        go t0 nullFrame initialStateName True

runInspect ::
       (Wrapped s -> [Control s])
    -> s
    -> (Double -> s -> s)
    -> (Event -> s -> s)
    -> (s -> Picture)
    -> IO ()
runInspect controls initial stepHandler eventHandler drawHandler =
    run (wrappedInitial initial)
        (wrappedStep stepHandler)
        (wrappedEvent controls stepHandler eventHandler)
        (wrappedDraw controls drawHandler)

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

groupActivityOf numPlayers initial event draw = do
    dhash <- getDeployHash
    let token =
            SteplessToken
            { tokenDeployHash = dhash
            , tokenNumPlayers = numPlayers
            , tokenInitial = staticKey initial
            , tokenEvent = staticKey event
            , tokenDraw = staticKey draw
            }
    runGame
        token
        numPlayers
        (deRefStaticPtr initial)
        (const id)
        (deRefStaticPtr event)
        (deRefStaticPtr draw)

unsafeGroupActivityOf numPlayers initial event draw =
    unsafeCollaborationOf numPlayers initial (const id) event draw

unsafeCollaborationOf numPlayers initial step event draw = do
    dhash <- getDeployHash
    let token = PartialToken dhash
    runGame token numPlayers initial step event draw
  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 activity, interaction, animation and simulation interfaces

activityOf initial change picture =
    interactionOf initial (const id) change picture

interactionOf = runInspect (const [])

data Wrapped a = Wrapped
    { state :: a
    , playbackSpeed :: Double
    , lastInteractionTime :: Double
    , zoomFactor :: Double
    , panCenter :: Point
    , panDraggingAnchor :: Maybe Point
    , isDraggingSpeed :: Bool
    , isDraggingHistory :: Bool
    , isDraggingZoom :: Bool
    } deriving (Show, Functor)

data Control :: * -> * where
    PlayButton :: Point -> Control a
    PauseButton :: Point -> Control a
    StepButton :: Point -> Control a
    RestartButton :: Point -> Control Double
    ZoomInButton :: Point -> Control a
    ZoomOutButton :: Point -> Control a
    PanningLayer :: Control a
    ResetViewButton :: Point -> Control a
    FastForwardButton :: Point -> Control a
    StartOverButton :: Point -> Control ([a], [a])
    BackButton :: Point -> Control Double
    TimeLabel :: Point -> Control Double
    SpeedSlider :: Point -> Control a
    ZoomSlider :: Point -> Control a
    UndoButton :: Point -> Control ([a], [a])
    RedoButton :: Point -> Control ([a], [a])
    HistorySlider :: Point -> Control ([a], [a])

wrappedInitial :: a -> Wrapped a
wrappedInitial w = Wrapped {
      state = w,
      playbackSpeed = 1,
      lastInteractionTime = 1000,
      zoomFactor = 1,
      panCenter = (0,0),
      panDraggingAnchor = Nothing,
      isDraggingSpeed = False,
      isDraggingHistory = False,
      isDraggingZoom = False
    }

toState :: (a -> a) -> (Wrapped a -> Wrapped a)
toState f w = case ifDifferent f (state w) of
    Just newState -> w { state = newState }
    _             -> w

wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a
wrappedStep f dt w = updateInteractionTime (updateState w)
  where updateInteractionTime w
          | lastInteractionTime w > 5 = w
          | otherwise = w { lastInteractionTime = lastInteractionTime w + dt }
        updateState w
          | playbackSpeed w == 0 = w
          | otherwise = toState (f (dt * playbackSpeed w)) w

reportDiff :: String -> (a -> a) -> (a -> a)
reportDiff msg f x = unsafePerformIO $ do
    a <- makeStableName $! x
    b <- makeStableName $! r
    when (a /= b) $ debugLog $ msg ++ ": reportDiff found a diff"
    return r
  where r = f x

wrappedEvent :: forall a .
       (Wrapped a -> [Control a])
    -> (Double -> a -> a)
    -> (Event -> a -> a)
    -> Event
    -> Wrapped a
    -> Wrapped a
wrappedEvent _ _ eventHandler (TimePassing dt) w
    | playbackSpeed w == 0 = w
    | otherwise = toState (eventHandler (TimePassing (dt * playbackSpeed w))) w
wrappedEvent ctrls stepHandler eventHandler event w
    | playbackSpeed w == 0 || handled = afterControls {lastInteractionTime = 0}
    | otherwise = toState (eventHandler (adaptEvent event)) afterControls {lastInteractionTime = 0}
  where
    (afterControls, handled) = foldr stepFunction (w, False) (ctrls w)

    stepFunction control (world, True) = (world, True)
    stepFunction control (world, False) = handleControl fullStep event control world

    fullStep dt = stepHandler dt . eventHandler (TimePassing dt)

    adaptEvent (PointerMovement p) = PointerMovement (adaptPoint p)
    adaptEvent (PointerPress p)    = PointerPress (adaptPoint p)
    adaptEvent (PointerRelease p)  = PointerRelease (adaptPoint p)
    adaptEvent other               = other

    adaptPoint (x, y) = (x / k - dx, y / k - dy)

    (dx, dy) = panCenter w
    k        = zoomFactor w

scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double
scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2

snapSlider :: Double -> [Double] -> Double -> Double
snapSlider eps targets val = foldr snap val targets
    where snap t v | abs (t - v) < eps = t
                   | otherwise         = v

xToPlaybackSpeed :: Double -> Double
xToPlaybackSpeed x = snapSlider 0.2 [1..4] $ scaleRange (-1.4, 1.4) (0, 5) x

playbackSpeedToX :: Double -> Double
playbackSpeedToX s = scaleRange (0, 5) (-1.4, 1.4) s

zoomIncrement = 8 ** (1/10)

yToZoomFactor :: Double -> Double
yToZoomFactor y = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) y)

zoomFactorToY :: Double -> Double
zoomFactorToY z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z)

handleControl ::
       (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool)
handleControl _ (PointerPress (x, y)) (RestartButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = 0}, True)
handleControl _ (PointerPress (x, y)) (StartOverButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (fmap f w, True)
  where
    f (past, future) = let x:xs = reverse past in ([x], xs ++ future)
handleControl _ (PointerPress (x, y)) (PlayButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 1}, True)
handleControl _ (PointerPress (x, y)) (PauseButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4  = (w {playbackSpeed = 0}, True)
handleControl _ (PointerPress (x, y)) (FastForwardButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4  = (w {playbackSpeed = min 5 $ max 2 $ playbackSpeed w + 1}, True)
handleControl _ (PointerPress (x, y)) (ZoomInButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = min (zoomIncrement ** 10) (zoomFactor w * zoomIncrement)}, True)
handleControl _ (PointerPress (x, y)) (ZoomOutButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = max (zoomIncrement ** (-10)) (zoomFactor w / zoomIncrement)}, True)
handleControl _ (PointerPress (x, y)) (ResetViewButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = 1, panCenter = (0, 0)}, True)
handleControl _ (PointerPress (x,y)) (BackButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 =
        (w {state = max 0 (state w - 0.1)}, True)
handleControl _ (PointerPress (x,y)) (UndoButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 =
        (fmap (\(x:xs, ys) -> (xs, x:ys)) w, True)
handleControl _ (PointerPress (x,y)) (RedoButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 =
        (fmap (\(xs, y:ys) -> (y:xs, ys)) w, True)
handleControl f (PointerPress (x, y)) (StepButton (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = f 0.1 (state w)}, True)
handleControl _ (PointerPress (x, y)) (SpeedSlider (cx, cy)) w
    | abs (x - cx) < 1.5 && abs (y - cy) < 0.4 =
      (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = True}, True)
handleControl _ (PointerMovement (x, y)) (SpeedSlider (cx, cy)) w
    | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx)}, True)
handleControl _ (PointerRelease (x, y)) (SpeedSlider (cx, cy)) w
    | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = False}, True)
handleControl _ (PointerPress (x, y)) (ZoomSlider (cx, cy)) w
    | abs (x - cx) < 0.4 && abs (y - cy) < 1.5 =
      (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = True}, True)
handleControl _ (PointerMovement (x, y)) (ZoomSlider (cx, cy)) w
    | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy)}, True)
handleControl _ (PointerRelease (x, y)) (ZoomSlider (cx, cy)) w
    | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = False}, True)
handleControl _ (PointerPress (x, y)) (HistorySlider (cx, cy)) w
    | abs (x - cx) < 2.5 && abs (y - cy) < 0.4 =
      (travelToTime (x - cx) <$> w {isDraggingHistory = True}, True)
handleControl _ (PointerMovement (x, y)) (HistorySlider (cx, cy)) w
    | isDraggingHistory w = (travelToTime (x - cx) <$> w, True)
handleControl _ (PointerRelease (x, y)) (HistorySlider (cx, cy)) w
    | isDraggingHistory w = (travelToTime (x - cx) <$> w {isDraggingHistory = False}, True)
handleControl _ (PointerPress (x, y)) PanningLayer w =
      (w {panDraggingAnchor = Just (x, y)}, True)
handleControl _ (PointerMovement (x, y)) PanningLayer w
    | Just (ax, ay) <- panDraggingAnchor w
    , (px, py) <- panCenter w
    = (w { panCenter = (px + (x - ax) / zoomFactor w, py + (y - ay) / zoomFactor w),
           panDraggingAnchor = Just (x, y)
         }, True)
handleControl _ (PointerRelease (x, y)) PanningLayer w
    | Just (ax, ay) <- panDraggingAnchor w = (w {panDraggingAnchor = Nothing}, True)
handleControl _ _ _ w = (w, False)

travelToTime :: Double -> ([s],[s]) -> ([s],[s])
travelToTime t (past, future)
    | n == 1    = (past, future)
    | otherwise = go past future (n1 - desiredN1)
  where n1 = length past
        n2 = length future
        n = n1 + n2
        desiredN1 = round (scaleRange (-2.4, 2.4) (1, fromIntegral n) t)
        go past future diff
          | diff > 0 = go (tail past) (head past : future) (diff - 1)
          | diff < 0 = go (head future : past) (tail future) (diff + 1)
          | otherwise = (past, future)

wrappedDraw ::
       (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture
wrappedDraw ctrls f w = drawControlPanel ctrls w <> dilated k (translated dx dy (f (state w)))
  where (dx, dy) = panCenter w
        k        = zoomFactor 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
        | lastInteractionTime w < 4.5 = 1
        | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w
        | otherwise = 0

drawControl :: Wrapped a -> Double -> Control a -> Picture
drawControl _ alpha (RestartButton (x,y)) = translated x y 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 (StartOverButton (x,y)) = translated x y 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 (x,y)) = translated x y 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 (x,y)) = translated x y 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 (FastForwardButton (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)] <>
             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 (ZoomInButton (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (translated (-0.05) (0.05) (
                thickCircle 0.1 0.22 <>
                solidRectangle 0.06 0.25 <>
                solidRectangle 0.25 0.06 <>
                rotated (-pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))
            )) <>
        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 (ZoomOutButton (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (translated (-0.05) (0.05) (
                thickCircle 0.1 0.22 <>
                solidRectangle 0.25 0.06 <>
                rotated (-pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))
            )) <>
        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 _ _ PanningLayer = blank
drawControl _ alpha (ResetViewButton (x,y)) = translated x y p
  where
    p =
        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.7 0.2) <>
        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.2 0.7) <>
        colored (RGBA 0.0 0.0 0.0 alpha) (thickRectangle 0.1 0.5 0.5) <>
        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 (x,y)) = translated x y 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 (UndoButton (x,y)) = translated x y 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 (x,y)) = translated x y 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 (RedoButton (x,y)) = translated x y 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 (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (scaled 0.5 0.5 $ lettering (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)
drawControl w alpha (SpeedSlider (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (translated xoff 0.75 $ scaled 0.5 0.5 $
                 lettering (pack (showFFloatAlt (Just 2) (playbackSpeed w) "x"))) <>
        colored (RGBA 0 0 0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) <>
        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.25) <>
        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.25)
    xoff = playbackSpeedToX (playbackSpeed w)
drawControl w alpha (ZoomSlider (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (translated (-1.1) yoff $ scaled 0.5 0.5 $
                 lettering (pack (show (round (zoomFactor w * 100) :: Int) ++ "%"))) <>
        colored (RGBA 0 0 0 alpha) (translated 0 yoff (solidRectangle 0.8 0.2)) <>
        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.25 2.8) <>
        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.25 2.8)
    yoff = zoomFactorToY (zoomFactor w)
drawControl w alpha (HistorySlider (x,y)) = translated x y p
  where
    p =
        colored
            (RGBA 0 0 0 alpha)
            (translated xoff 0.75 $ scaled 0.5 0.5 $
                 lettering (pack (show n1 ++ "/" ++ show (n1 + n2)))) <>
        colored (RGBA 0.0 0.0 0.0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) <>
        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 4.8 0.25) <>
        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 4.8 0.25)
    xoff | n < 2 = 2.4
         | otherwise   = scaleRange (1, fromIntegral n) (-2.4, 2.4) (fromIntegral n1)
    n1 = length (fst (state w))
    n2 = length (snd (state w))
    n  = n1 + n2

drawingControls :: Wrapped () -> [Control ()]
drawingControls w
    | lastInteractionTime w > 5 = []
    | otherwise = commonControls ++ resetViewButton
  where
    commonControls = [
        PanningLayer,
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]
      | otherwise = []

drawingOf pic = runInspect drawingControls () (\_ _ -> ()) (\_ _ -> ()) (const pic)

animationControls :: Wrapped Double -> [Control Double]
animationControls w
    | lastInteractionTime w > 5 = []
    | otherwise = commonControls ++ pauseDependentControls ++
                  backButton ++ resetViewButton
  where
    commonControls = [
        PanningLayer,
        RestartButton (-9, -9),
        TimeLabel (8, -9),
        SpeedSlider (-3, -9),
        FastForwardButton (-1, -9),
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    pauseDependentControls
      | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-6, -9)]
      | otherwise = [PauseButton (-8, -9)]
    backButton
      | playbackSpeed w == 0 && state w > 0 = [BackButton (-7, -9)]
      | otherwise = []
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]
      | otherwise = []

animationOf f = runInspect animationControls 0 (+) (\_ r -> r) f

simulationControls :: Wrapped w -> [Control w]
simulationControls w
    | lastInteractionTime w > 5 = []
    | otherwise = commonControls ++ pauseDependentControls ++ resetViewButton
  where
    commonControls = [
        PanningLayer,
        FastForwardButton (-4, -9),
        SpeedSlider (-6, -9),
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    pauseDependentControls
      | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-2, -9)]
      | otherwise = [PauseButton (-8, -9)]
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]
      | otherwise = []

statefulDebugControls :: Wrapped ([w],[w]) -> [Control ([w],[w])]
statefulDebugControls w
    | lastInteractionTime w > 5 = []
    | otherwise = panningLayer ++ pauseDependentControls ++ commonControls ++
                  resetViewButton
  where
    hasHistory = not (null (tail (fst (state w))))
    hasFuture  = not (null (snd (state w)))
    advance | hasFuture  = [RedoButton (6, -9)]
            | otherwise  = [StepButton (6, -9)]
    regress | hasHistory = [UndoButton (0, -9)]
            | otherwise  = []
    commonControls = [
        StartOverButton (-1, -9),
        FastForwardButton (-4, -9),
        SpeedSlider (-6, -9),
        ZoomInButton (9, -4),
        ZoomOutButton (9, -8),
        ZoomSlider (9, -6)
      ]
    pauseDependentControls
      | playbackSpeed w == 0 =
            [PlayButton (-8, -9), HistorySlider (3, -9)] ++ advance ++ regress
      | otherwise = [PauseButton (-8, -9)]
    resetViewButton
      | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]
      | otherwise = []
    panningLayer
      | playbackSpeed w == 0 = [PanningLayer]
      | otherwise = []

simulationOf initial step draw =
    runInspect simulationControls initial step (\_ r -> r) draw

prependIfChanged :: (a -> a) -> ([a],[a]) -> ([a],[a])
prependIfChanged f (x:xs, ys) =
    case x `seq` x' `seq` (reallyUnsafePtrEquality# x x') of
        0# -> (x' : x : xs, [])
        _  -> (x : xs, ys)
  where x' = f x

debugSimulationOf initial simStep simDraw =
    runInspect statefulDebugControls ([initial],[]) step (\_ r -> r) draw
  where
    step dt = prependIfChanged (simStep dt)
    draw (x:_, _) = simDraw x

debugInteractionOf initial baseStep baseEvent baseDraw =
  runInspect statefulDebugControls ([initial], []) step event draw
  where
    step dt = prependIfChanged (baseStep dt)
    event e = prependIfChanged (baseEvent e)
    draw (x:_, _) = baseDraw x

debugActivityOf initial change picture =
    debugInteractionOf initial (const id) change picture

trace msg x = unsafePerformIO $ do
    hPutStrLn stderr (T.unpack msg)
    return x