codeworld-api 0.2.1.0 → 0.2.2.0

raw patch · 9 files changed

+2915/−1769 lines, 9 filesdep +random-shuffledep +transformersdep ~basedep ~ghcjs-domdep ~timesetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random-shuffle, transformers

Dependency ranges changed: base, ghcjs-dom, time

API changes (from Hackage documentation)

Files

• Setup.hs +2/−2
• codeworld-api.cabal +10/−7
• src/CodeWorld.hs +106/−95
• src/CodeWorld/CanvasM.hs +214/−0
• src/CodeWorld/CollaborationUI.hs +164/−153
• src/CodeWorld/Color.hs +144/−64
• src/CodeWorld/Driver.hs +2080/−1335
• src/CodeWorld/Event.hs +29/−10
• src/CodeWorld/Picture.hs +166/−103

@@ -1,5 +1,5 @@ {--  Copyright 2016 The CodeWorld Authors. All rights reserved.+  Copyright 2018 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.@@ -13,6 +13,6 @@   See the License for the specific language governing permissions and   limitations under the License. -}- import Distribution.Simple+ main = defaultMain

@@ -1,11 +1,11 @@ Name:                codeworld-api-Version:             0.2.1.0+Version:             0.2.2.0 Synopsis:            Graphics library for CodeWorld License:             Apache License-file:        LICENSE Author:              The CodeWorld Authors Maintainer:          Chris Smith <cdsmith@gmail.com>-Copyright:           (c) 2016, The CodeWorld Authors+Copyright:           (c) 2018, The CodeWorld Authors Build-type:          Simple Cabal-version:       >=1.8 @@ -21,7 +21,8 @@ Library   Hs-source-dirs:      src   Exposed-modules:     CodeWorld-  Other-modules:       CodeWorld.Color,+  Other-modules:       CodeWorld.CanvasM,+                       CodeWorld.Color,                        CodeWorld.Picture,                        CodeWorld.Event,                        CodeWorld.Driver@@ -31,20 +32,22 @@                        hashable             >= 1.2.4 && < 1.3,                        text                 >= 1.2.2 && < 1.3,                        mtl                  >= 2.2.1 && < 2.3,-                       time                 >= 1.6.0 && < 1.7,                        random               >= 1.1 && < 1.2,+                       random-shuffle       >= 0.0.4 && < 0.1,                        cereal               >= 0.5.4 && < 0.6,                        cereal-text          >= 0.1.0 && < 0.2    if impl(ghcjs)     Build-depends:                        ghcjs-base,-                       ghcjs-dom,                        ghcjs-prim,                        codeworld-game-api,-                       codeworld-prediction+                       codeworld-prediction,+                       ghcjs-dom             >= 0.8 && < 0.9,+                       transformers   else-    Build-depends:     blank-canvas         >= 0.6 && < 0.7+    Build-depends:     blank-canvas          >= 0.6 && < 0.7,+                       time                  >= 1.6.0 && < 1.9    Exposed:             True   Ghc-options:         -O2

@@ -1,5 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+ {--  Copyright 2016 The CodeWorld Authors. All rights reserved.+  Copyright 2018 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.@@ -13,108 +15,117 @@   See the License for the specific language governing permissions and   limitations under the License. -}- module CodeWorld (     -- * Entry points-    drawingOf,-    animationOf,-    simulationOf,-    interactionOf,-    collaborationOf,-    unsafeCollaborationOf,-+      drawingOf+    , animationOf+    , simulationOf+    , interactionOf+    , collaborationOf+    , unsafeCollaborationOf     -- * Pictures-    Picture,-    TextStyle(..),-    Font(..),-    blank,-    path,-    thickPath,-    polygon,-    thickPolygon,-    solidPolygon,-    curve,-    thickCurve,-    loop,-    thickLoop,-    solidLoop,-    rectangle,-    solidRectangle,-    thickRectangle,-    circle,-    solidCircle,-    thickCircle,-    arc,-    sector,-    thickArc,-    text,-    styledText,-    colored,-    coloured,-    translated,-    scaled,-    dilated,-    rotated,-    pictures,-    (<>),-    (&),-    coordinatePlane,-    codeWorldLogo,-    Point,-    Vector,-    vectorSum,-    vectorDifference,-    scaledVector,-    rotatedVector,-    dotProduct,-+    , Picture+    , TextStyle(..)+    , Font(..)+    , blank+    , polyline+    , path+    , thickPolyline+    , thickPath+    , polygon+    , thickPolygon+    , solidPolygon+    , curve+    , thickCurve+    , closedCurve+    , loop+    , thickClosedCurve+    , thickLoop+    , solidClosedCurve+    , solidLoop+    , rectangle+    , solidRectangle+    , thickRectangle+    , circle+    , solidCircle+    , thickCircle+    , arc+    , sector+    , thickArc+    , text+    , styledText+    , colored+    , coloured+    , translated+    , scaled+    , dilated+    , rotated+    , pictures+    , (<>)+    , (&)+    , coordinatePlane+    , codeWorldLogo+    , Point+    , Vector+    , vectorLength+    , vectorDirection+    , vectorSum+    , vectorDifference+    , scaledVector+    , rotatedVector+    , dotProduct     -- * Colors-    Color(..),-    Colour,-    black,-    white,-    red,-    green,-    blue,-    cyan,-    magenta,-    yellow,-    aquamarine,-    orange,-    azure,-    violet,-    chartreuse,-    rose,-    brown,-    pink,-    purple,-    gray,-    grey,-    mixed,-    lighter,-    light,-    darker,-    dark,-    brighter,-    bright,-    duller,-    dull,-    translucent,-    hue,-    saturation,-    luminosity,-    fromHSL,-+    , Color(..)+    , Colour+    , pattern RGB+    , pattern HSL+    , black+    , white+    , red+    , green+    , blue+    , cyan+    , magenta+    , yellow+    , aquamarine+    , orange+    , azure+    , violet+    , chartreuse+    , rose+    , brown+    , pink+    , purple+    , gray+    , grey+    , mixed+    , lighter+    , light+    , darker+    , dark+    , brighter+    , bright+    , duller+    , dull+    , translucent+    , assortedColors+    , hue+    , saturation+    , luminosity+    , alpha+    , fromHSL     -- * Events-    Event(..),-    MouseButton(..),-+    , Event(..)+    , MouseButton(..)+    , pattern PointerPress+    , pattern PointerRelease+    , pattern PointerMovement     -- * Debugging-    trace+    , trace     ) where  import CodeWorld.Color-import CodeWorld.Picture-import CodeWorld.Event import CodeWorld.Driver+import CodeWorld.Event+import CodeWorld.Picture import Data.Monoid

@@ -0,0 +1,214 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++{-+  Copyright 2018 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.CanvasM where++import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans (liftIO)+import Data.Text (Text, pack)++#ifdef ghcjs_HOST_OS++import Data.JSString.Text+import GHCJS.Marshal.Pure+import GHCJS.Types+import qualified JavaScript.Web.Canvas as Canvas+import qualified JavaScript.Web.Canvas.Internal as Canvas++#else++import qualified Graphics.Blank as Canvas+import Graphics.Blank (Canvas)+import Text.Printf++#endif++class Monad m => MonadCanvas m where+    type Image m++    save :: m ()+    restore :: m ()+    transform ::+           Double -> Double -> Double -> Double -> Double -> Double -> m ()+    translate :: Double -> Double -> m ()+    scale :: Double -> Double -> m ()+    newImage :: Int -> Int -> m () -> m (Image m)+    drawImage :: Image m -> Int -> Int -> Int -> Int -> m ()+    globalCompositeOperation :: Text -> m ()+    lineWidth :: Double -> m ()+    strokeColor :: Int -> Int -> Int -> Double -> m ()+    fillColor :: Int -> Int -> Int -> Double -> m ()+    font :: Text -> m ()+    textCenter :: m ()+    textMiddle :: m ()+    beginPath :: m ()+    closePath :: m ()+    moveTo :: (Double, Double) -> m ()+    lineTo :: (Double, Double) -> m ()+    quadraticCurveTo :: (Double, Double) -> (Double, Double) -> m ()+    bezierCurveTo ::+           (Double, Double) -> (Double, Double) -> (Double, Double) -> m ()+    arc :: Double -> Double -> Double -> Double -> Double -> Bool -> m ()+    rect :: Double -> Double -> Double -> Double -> m ()+    fill :: m ()+    stroke :: m ()+    fillRect :: Double -> Double -> Double -> Double -> m ()+    fillText :: Text -> (Double, Double) -> m ()+    measureText :: Text -> m Double+    isPointInPath :: (Double, Double) -> m Bool+    isPointInStroke :: (Double, Double) -> m Bool++saveRestore :: MonadCanvas m => m a -> m a+saveRestore m = do+    save+    r <- m+    restore+    return r++#ifdef ghcjs_HOST_OS++data CanvasM a = CanvasM+    { unCanvasM :: Canvas.Context -> IO a+    } deriving (Functor)++instance Applicative CanvasM where+    pure x = CanvasM (const (return x))+    f <*> x = CanvasM (\ctx -> unCanvasM f ctx <*> unCanvasM x ctx)++instance Monad CanvasM where+    return = pure+    m >>= f = CanvasM (\ctx -> unCanvasM m ctx >>= ($ ctx) . unCanvasM . f)++foreign import javascript "$2.globalCompositeOperation = $1;"+               js_globalCompositeOperation :: JSString -> Canvas.Context -> IO ()++foreign import javascript "$r = $3.isPointInPath($1, $2);"+               js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool++foreign import javascript "$r = $3.isPointInStroke($1, $2);"+               js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool++instance MonadCanvas CanvasM where+    type Image CanvasM = Canvas.Canvas+    save = CanvasM Canvas.save+    restore = CanvasM Canvas.restore+    transform a b c d e f = CanvasM (Canvas.transform a b c d e f)+    translate x y = CanvasM (Canvas.translate x y)+    scale x y = CanvasM (Canvas.scale x y)+    newImage w h m =+        CanvasM $+        const $ do+            buf <- Canvas.create w h+            ctx <- Canvas.getContext buf+            unCanvasM m ctx+            return buf+    drawImage (Canvas.Canvas c) x y w h =+        CanvasM (Canvas.drawImage (Canvas.Image c) x y w h)+    globalCompositeOperation op =+        CanvasM (js_globalCompositeOperation (textToJSString op))+    lineWidth w = CanvasM (Canvas.lineWidth w)+    strokeColor r g b a = CanvasM (Canvas.strokeStyle r g b a)+    fillColor r g b a = CanvasM (Canvas.fillStyle r g b a)+    font t = CanvasM (Canvas.font (textToJSString t))+    textCenter = CanvasM (Canvas.textAlign Canvas.Center)+    textMiddle = CanvasM (Canvas.textBaseline Canvas.Middle)+    beginPath = CanvasM Canvas.beginPath+    closePath = CanvasM Canvas.closePath+    moveTo (x, y) = CanvasM (Canvas.moveTo x y)+    lineTo (x, y) = CanvasM (Canvas.lineTo x y)+    quadraticCurveTo (x1, y1) (x2, y2) =+        CanvasM (Canvas.quadraticCurveTo x1 y1 x2 y2)+    bezierCurveTo (x1, y1) (x2, y2) (x3, y3) =+        CanvasM (Canvas.bezierCurveTo x1 y1 x2 y2 x3 y3)+    arc x y r a1 a2 dir = CanvasM (Canvas.arc x y r a1 a2 dir)+    rect x y w h = CanvasM (Canvas.rect x y w h)+    fill = CanvasM Canvas.fill+    stroke = CanvasM Canvas.stroke+    fillRect x y w h = CanvasM (Canvas.fillRect x y w h)+    fillText t (x, y) = CanvasM (Canvas.fillText (textToJSString t) x y)+    measureText t = CanvasM (Canvas.measureText (textToJSString t))+    isPointInPath (x, y) = CanvasM (js_isPointInPath x y)+    isPointInStroke (x, y) = CanvasM (js_isPointInStroke x y)++#else++instance MonadCanvas Canvas where+    type Image Canvas = Canvas.CanvasContext+    save = Canvas.save ()+    restore = Canvas.restore ()+    transform a b c d e f = Canvas.transform (a, b, c, d, e, f)+    translate x y = Canvas.translate (x, y)+    scale x y = Canvas.scale (x, y)+    newImage w h m = do+        ctx <- Canvas.newCanvas (w, h)+        Canvas.with ctx m+        return ctx+    drawImage img x y w h =+        Canvas.drawImageSize+            ( img+            , fromIntegral x+            , fromIntegral y+            , fromIntegral w+            , fromIntegral h)+    globalCompositeOperation op = Canvas.globalCompositeOperation op+    lineWidth w = Canvas.lineWidth w+    strokeColor r g b a =+        Canvas.strokeStyle+            (pack+                 (printf+                      "rgba(%.0f,%.0f,%.0f,%f)"+                      (r * 255)+                      (g * 255)+                      (b * 255)+                      a))+    fillColor r g b a =+        Canvas.fillStyle+            (pack+                 (printf+                      "rgba(%.0f,%.0f,%.0f,%f)"+                      (r * 255)+                      (g * 255)+                      (b * 255)+                      a))+    font t = Canvas.font t+    textCenter = Canvas.textAlign Canvas.CenterAnchor+    textMiddle = Canvas.textBaseline Canvas.MiddleBaseline+    beginPath = Canvas.beginPath ()+    closePath = Canvas.closePath ()+    moveTo (x, y) = Canvas.moveTo (x, y)+    lineTo (x, y) = Canvas.lineTo (x, y)+    quadraticCurveTo (x1, y1) (x2, y2) =+        Canvas.quadraticCurveTo (x1, y1, x2, y2)+    bezierCurveTo (x1, y1) (x2, y2) (x3, y3) =+        Canvas.bezierCurveTo (x1, y1, x2, y2, x3, y3)+    arc x y r a1 a2 dir = Canvas.arc (x, y, r, a1, a2, dir)+    rect x y w h = Canvas.rect (x, y, w, h)+    fill = Canvas.fill ()+    stroke = Canvas.stroke ()+    fillRect x y w h = Canvas.fillRect (x, y, w, h)+    fillText t (x, y) = Canvas.fillText (t, x, y)+    measureText t = do+        Canvas.TextMetrics w <- Canvas.measureText t+        return w+    isPointInPath (x, y) = Canvas.isPointInPath (x, y)+    isPointInStroke (x, y) = return False++#endif

@@ -1,15 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ParallelListComp  #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE PatternGuards     #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE TypeFamilies      #-}-{-# LANGUAGE GADTs             #-}-{-# LANGUAGE PatternSynonyms   #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  {--  Copyright 2017 The CodeWorld Authors. All rights reserved.+  Copyright 2018 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.@@ -23,27 +22,26 @@   See the License for the specific language governing permissions and   limitations under the License. -}- module CodeWorld.CollaborationUI-  ( UIState-  , SetupPhase(..)-  , Step(..)-  , initial-  , step-  , event-  , picture-  , startWaiting-  , updatePlayers-  ) where+    ( UIState+    , SetupPhase(..)+    , Step(..)+    , initial+    , step+    , event+    , picture+    , startWaiting+    , updatePlayers+    ) where  import CodeWorld.Color-import CodeWorld.Picture import CodeWorld.Event+import CodeWorld.Picture  import Data.Char+import Data.Monoid import qualified Data.Text as T import Data.Text (Text)-import Data.Monoid  -- | The enumeration type contains all the high-level states that the game UI -- can be in. It is used as a type-index to 'UIState' to ensure that the UI@@ -51,101 +49,114 @@ -- -- The possible UI-triggered transitions of this state are described by -- 'Step'.-data SetupPhase = SMain | SConnect | SWait-+data SetupPhase+    = SMain+    | SConnect+    | SWait  -- | Possible steps taken from a given setup phase data family Step :: (SetupPhase -> *) -> SetupPhase -> *-data instance Step f SMain-    = ContinueMain    (f SMain)-    | Create          (f SConnect)-    | Join Text       (f SConnect)-data instance Step f SConnect-    = ContinueConnect (f SConnect)-    | CancelConnect   (f SMain)-data instance Step f SWait-    = ContinueWait    (f SWait)-    | CancelWait      (f SMain) +data instance  Step f SMain = ContinueMain (f SMain)+                            | Create (f SConnect)+                            | Join Text (f SConnect)++data instance  Step f SConnect = ContinueConnect (f SConnect)+                               | CancelConnect (f SMain)++data instance  Step f SWait = ContinueWait (f SWait)+                            | CancelWait (f SMain)+ -- | The UI state, indexed by the 'SetupPhase' data UIState (s :: SetupPhase) where-    MainMenu    :: Double -> Point-                -> UIState SMain-    Joining     :: Double -> Point-                -> Text-                -> UIState SMain-    Connecting  :: Double-                -> Point-                -> UIState SConnect-    Waiting     :: Double -> Point-                -> Text -> {- numPlayers :: -} Int  -> {- present -} Int-                -> UIState SWait+    MainMenu :: Double -> Point -> UIState SMain+    Joining :: Double -> Point -> Text -> UIState SMain+    Connecting :: Double -> Point -> UIState SConnect+    Waiting+        :: Double+        -> Point+        -> Text+        -> Int+        -> Int {- numPlayers :: -}+            {- present -}+        -> UIState SWait  continueUIState :: UIState s -> Step UIState s-continueUIState s@(MainMenu   {}) = ContinueMain s-continueUIState s@(Joining    {}) = ContinueMain s-continueUIState s@(Connecting {}) = ContinueConnect s-continueUIState s@(Waiting    {}) = ContinueWait s-+continueUIState s@MainMenu {} = ContinueMain s+continueUIState s@Joining {} = ContinueMain s+continueUIState s@Connecting {} = ContinueConnect s+continueUIState s@Waiting {} = ContinueWait s  time :: UIState s -> Double-time (MainMenu   t _)       = t-time (Joining    t _ _)     = t-time (Connecting t _)       = t-time (Waiting    t _ _ _ _) = t+time (MainMenu t _) = t+time (Joining t _ _) = t+time (Connecting t _) = t+time (Waiting t _ _ _ _) = t  mousePos :: UIState s -> Point-mousePos (MainMenu   _ p)       = p-mousePos (Joining    _ p _)     = p-mousePos (Connecting _ p)       = p-mousePos (Waiting    _ p _ _ _) = p+mousePos (MainMenu _ p) = p+mousePos (Joining _ p _) = p+mousePos (Connecting _ p) = p+mousePos (Waiting _ p _ _ _) = p  -- Takes an absolute time, not a delta. A bit easier. step :: Double -> UIState s -> UIState s-step t (MainMenu   _ p)       = MainMenu   t p-step t (Joining    _ p c)     = Joining    t p c-step t (Connecting _ p)       = Connecting t p-step t (Waiting    _ p c n m) = Waiting    t p c n m+step t (MainMenu _ p) = MainMenu t p+step t (Joining _ p c) = Joining t p c+step t (Connecting _ p) = Connecting t p+step t (Waiting _ p c n m) = Waiting t p c n m  setMousePos :: Point -> UIState s -> UIState s-setMousePos p (MainMenu   t _)       = MainMenu   t p-setMousePos p (Joining    t _ c)     = Joining    t p c-setMousePos p (Connecting t _)       = Connecting t p-setMousePos p (Waiting    t _ c n m) = Waiting    t p c n m-+setMousePos p (MainMenu t _) = MainMenu t p+setMousePos p (Joining t _ c) = Joining t p c+setMousePos p (Connecting t _) = Connecting t p+setMousePos p (Waiting t _ c n m) = Waiting t p c n m  initial :: UIState SMain-initial = MainMenu 0 (0,0)+initial = MainMenu 0 (0, 0)  startWaiting :: Text -> UIState a -> UIState SWait startWaiting code s = Waiting (time s) (mousePos s) code 0 0  updatePlayers :: Int -> Int -> UIState SWait -> UIState SWait-updatePlayers n m (Waiting time mousePos code _ _)-                 = Waiting time mousePos code n m+updatePlayers n m (Waiting time mousePos code _ _) =+    Waiting time mousePos code n m  -- | Handling a UI event. May change the phase. event :: Event -> UIState s -> Step UIState s event (MouseMovement p) s = continueUIState (setMousePos p s)-event CreateClick     (MainMenu t p)                          = Create        (Connecting t p)-event JoinClick       (MainMenu t p)                          = ContinueMain  (Joining t p "")-event (LetterPress k) (Joining t p code) | T.length code < 4  = ContinueMain  (Joining t p (code <> k))-event BackSpace       (Joining t p code) | T.length code > 0  = ContinueMain  (Joining t p (T.init code))-event ConnectClick    (Joining t p code) | T.length code == 4 = Join code     (Connecting t p)-event CancelClick     (Joining t p code)                      = ContinueMain  (MainMenu t p)-event CancelClick     (Connecting t p)                        = CancelConnect (MainMenu t p)-event CancelClick     (Waiting t p c n m)                     = CancelWait    (MainMenu t p)-event _               s                                       = continueUIState s+event CreateClick (MainMenu t p) = Create (Connecting t p)+event JoinClick (MainMenu t p) = ContinueMain (Joining t p "")+event (LetterPress k) (Joining t p code)+    | T.length code < 4 = ContinueMain (Joining t p (code <> k))+event BackSpace (Joining t p code)+    | T.length code > 0 = ContinueMain (Joining t p (T.init code))+event ConnectClick (Joining t p code)+    | T.length code == 4 = Join code (Connecting t p)+event CancelClick (Joining t p code) = ContinueMain (MainMenu t p)+event CancelClick (Connecting t p) = CancelConnect (MainMenu t p)+event CancelClick (Waiting t p c n m) = CancelWait (MainMenu t p)+event _ s = continueUIState s -pattern CreateClick   <- MousePress LeftButton (inButton 0 ( 1.5) 8 2 -> True)-pattern JoinClick     <- MousePress LeftButton (inButton 0 (-1.5) 8 2 -> True)-pattern ConnectClick  <- MousePress LeftButton (inButton 0 (-  3) 8 2 -> True)+pattern CreateClick <-+        MousePress LeftButton (inButton 0 1.5 8 2 -> True)++pattern JoinClick <-+        MousePress LeftButton (inButton 0 (-1.5) 8 2 -> True)++pattern ConnectClick <-+        MousePress LeftButton (inButton 0 (-3.0) 8 2 -> True)+ pattern LetterPress c <- (isLetterPress -> Just c)-pattern BackSpace     <- KeyPress "Backspace"-pattern CancelClick   <- (isCancelClick -> True) +pattern BackSpace <- KeyPress "Backspace"++pattern CancelClick <- (isCancelClick -> True)+ isLetterPress :: Event -> Maybe Text-isLetterPress (KeyPress k) | T.length k == 1, isLetter (T.head k) = Just (T.toUpper k)+isLetterPress (KeyPress k)+    | T.length k == 1+    , isLetter (T.head k) = Just (T.toUpper k) isLetterPress _ = Nothing  isCancelClick :: Event -> Bool@@ -153,91 +164,91 @@ isCancelClick (MousePress LeftButton point) = inButton 0 (-3) 8 2 point isCancelClick _ = False - picture :: UIState s -> Picture-picture (MainMenu time mousePos)-    = button "New" (dull green) 0 ( 1.5) 8 2 mousePos-    & button "Join" (dull green) 0 (-1.5) 8 2 mousePos-    & connectScreen "Main Menu" time--picture (Joining time mousePos code)-    = translated 0 2 (text "Enter the game key:")-    & letterBoxes white code-    & (if T.length code < 4-       then button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos-       else button "Join" (dull green) 0 (-3) 8 2 mousePos)-    & connectScreen "Join Game" time--picture (Connecting time mousePos)-    = button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos-    & connectScreen "Connecting..." time--picture (Waiting time mousePos code numPlayers present)-    = translated 0 2 (text "Share this key with other players:")-    & translated 0 4 (playerDots numPlayers present)-    & letterBoxes (gray 0.8) code-    & button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos-    & connectScreen "Waiting" time+picture (MainMenu time mousePos) =+    button "New" (dull green) 0 1.5 8 2 mousePos &+    button "Join" (dull green) 0 (-1.5) 8 2 mousePos &+    connectScreen "Main Menu" time+picture (Joining time mousePos code) =+    translated 0 2 (text "Enter the game key:") & letterBoxes white code &+    (if T.length code < 4+         then button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos+         else button "Join" (dull green) 0 (-3) 8 2 mousePos) &+    connectScreen "Join Game" time+picture (Connecting time mousePos) =+    button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos &+    connectScreen "Connecting..." time+picture (Waiting time mousePos code numPlayers present) =+    translated 0 2 (text "Share this key with other players:") &+    translated 0 4 (playerDots numPlayers present) &+    letterBoxes (gray 0.8) code &+    button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos &+    connectScreen "Waiting" time  letterBoxes :: Color -> Text -> Picture-letterBoxes color txt = pictures-    [ translated x 0 (letterBox color (T.singleton c))-    | c <- pad 4 ' ' (take 4 (T.unpack txt))-    | x <- [-3, -1, 1, 3] ]+letterBoxes color txt =+    pictures+        [ translated x 0 (letterBox color (T.singleton c))+        | c <- pad 4 ' ' (take 4 (T.unpack txt))+        | x <- [-3, -1, 1, 3]+        ]  letterBox :: Color -> Text -> Picture-letterBox c t = thickRectangle 0.1 1.5 1.5-              & text t-              & colored c (solidRectangle 1.5 1.5)+letterBox c t =+    thickRectangle 0.1 1.5 1.5 & text t & colored c (solidRectangle 1.5 1.5)  pad :: Int -> a -> [a] -> [a]-pad 0 _ xs     = xs+pad 0 _ xs = xs pad n v (x:xs) = x : pad (n - 1) v xs-pad n v []     = v : pad (n - 1) v []+pad n v [] = v : pad (n - 1) v []  inButton :: Double -> Double -> Double -> Double -> Point -> Bool inButton x y w h (mx, my) =-    mx >= x - w / 2 &&-    mx <= x + w / 2 &&-    my >= y - h / 2 &&-    my <= y + h / 2+    mx >= x - w / 2 && mx <= x + w / 2 && my >= y - h / 2 && my <= y + h / 2 -button :: Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture-button txt btnColor x y w h (mx, my) = translated x y $+button ::+       Text -> Color -> Double -> Double -> Double -> Double -> Point -> Picture+button txt btnColor x y w h (mx, my) =+    translated x y $     colored white (styledText Plain SansSerif txt) &     colored color (roundRect w h)-  where color | inButton x y w h (mx, my) = btnColor-              | otherwise                 = dark btnColor+  where+    color+        | inButton x y w h (mx, my) = btnColor+        | otherwise = dark btnColor  roundRect :: Double -> Double -> Picture-roundRect w h = solidRectangle w (h - 0.5)-              & solidRectangle (w - 0.5) h-              & pictures [ translated x y (solidCircle 0.25)-                         | x <- [ -w / 2 + 0.25, w / 2 - 0.25 ]-                         , y <- [ -h / 2 + 0.25, h / 2 - 0.25 ] ]--playerDots n m | n > 8 = text $ T.pack $ show m ++" / "++ show n-playerDots n m = pictures-    [ translated (size*fromIntegral i - size*fromIntegral n/2) 0 (dot (i <= m))-    | i <- [1..n]-    ]-  where dot True  = solidCircle (0.4*size)-        dot False = circle (0.4*size)-        size = 1-+roundRect w h =+    solidRectangle w (h - 0.5) & solidRectangle (w - 0.5) h &+    pictures+        [ translated x y (solidCircle 0.25)+        | x <- [-w / 2 + 0.25, w / 2 - 0.25]+        , y <- [-h / 2 + 0.25, h / 2 - 0.25]+        ] +playerDots n m+    | n > 8 = text $ T.pack $ show m ++ " / " ++ show n+playerDots n m =+    pictures+        [ translated+            (size * fromIntegral i - size * fromIntegral n / 2)+            0+            (dot (i <= m))+        | i <- [1 .. n]+        ]+  where+    dot True = solidCircle (0.4 * size)+    dot False = circle (0.4 * size)+    size = 1  connectScreen :: Text -> Double -> Picture-connectScreen hdr t = translated 0 7 connectBox-        & translated 0 (-7) codeWorldLogo-        & colored (RGBA 0.85 0.86 0.9 1) (solidRectangle 20 20)+connectScreen hdr t =+    translated 0 7 connectBox & translated 0 (-7) codeWorldLogo &+    colored (RGBA 0.85 0.86 0.9 1) (solidRectangle 20 20)   where-    connectBox = scaled 2 2 (text hdr)-               & rectangle 14 3-               & colored connectColor (solidRectangle 14 3)-    connectColor = let k = (1 + sin (3 * t)) / 5-                   in  fromHSL (k + 0.5) 0.8 0.7----+    connectBox =+        scaled 2 2 (text hdr) & rectangle 14 3 &+        colored connectColor (solidRectangle 14 3)+    connectColor =+        let k = (1 + sin (3 * t)) / 5+        in fromHSL (k + 0.5) 0.8 0.7

@@ -1,5 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+ {--  Copyright 2016 The CodeWorld Authors. All rights reserved.+  Copyright 2018 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.@@ -13,56 +16,128 @@   See the License for the specific language governing permissions and   limitations under the License. -}- module CodeWorld.Color where -data Color = RGBA !Double !Double !Double !Double deriving (Show, Eq)+import Data.Fixed (mod')+import Data.List (unfoldr)++import System.Random (mkStdGen)+import System.Random.Shuffle (shuffle')++data Color =+    RGBA !Double+         !Double+         !Double+         !Double+    deriving (Show, Eq)+ type Colour = Color +pattern RGB :: Double -> Double -> Double -> Color++pattern RGB r g b = RGBA r g b 1++pattern HSL :: Double -> Double -> Double -> Color++pattern HSL h s l <- (toHSL -> Just (h, s, l))+  where HSL h s l = fromHSL h s l++-- Utility functions for pattern synonyms.+fence :: Double -> Double+fence = max 0 . min 1++wrapNum :: Double -> Double -> Double+wrapNum lim x = x - fromInteger (floor (x / lim)) * lim++fenceColor :: Color -> Color+fenceColor (RGBA r g b a) = RGBA (fence r) (fence g) (fence b) (fence a)++-- Based on the algorithm from the CSS3 specification.+fromHSL :: Double -> Double -> Double -> Color+fromHSL (wrapNum (2 * pi) -> h) (fence -> s) (fence -> l) = RGBA r g b 1+  where+    m1 = l * 2 - m2+    m2+        | l <= 0.5 = l * (s + 1)+        | otherwise = l + s - l * s+    r = convert m1 m2 (h / 2 / pi + 1 / 3)+    g = convert m1 m2 (h / 2 / pi)+    b = convert m1 m2 (h / 2 / pi - 1 / 3)+    convert m1 m2 h+        | h < 0 = convert m1 m2 (h + 1)+        | h > 1 = convert m1 m2 (h - 1)+        | h * 6 < 1 = m1 + (m2 - m1) * h * 6+        | h * 2 < 1 = m2+        | h * 3 < 2 = m1 + (m2 - m1) * (2 / 3 - h) * 6+        | otherwise = m1++{-# WARNING+fromHSL "Please use HSL instead of fromHSL."+ #-}++toHSL :: Color -> Maybe (Double, Double, Double)+toHSL c@(RGBA _ _ _ 1) = Just (hue c, saturation c, luminosity c)+toHSL _ = Nothing+ white, black :: Color white = RGBA 1 1 1 1+ black = RGBA 0 0 0 1  -- Primary and secondary colors red, green, blue, cyan, magenta, yellow :: Color-red        = fromHSL (0/3 * pi) 0.75 0.5-yellow     = fromHSL (1/3 * pi) 0.75 0.5-green      = fromHSL (2/3 * pi) 0.75 0.5-cyan       = fromHSL (3/3 * pi) 0.75 0.5-blue       = fromHSL (4/3 * pi) 0.75 0.5-magenta    = fromHSL (5/3 * pi) 0.75 0.5+red = fromHSL (0 / 3 * pi) 0.75 0.5 +yellow = fromHSL (1 / 3 * pi) 0.75 0.5++green = fromHSL (2 / 3 * pi) 0.75 0.5++cyan = fromHSL (3 / 3 * pi) 0.75 0.5++blue = fromHSL (4 / 3 * pi) 0.75 0.5++magenta = fromHSL (5 / 3 * pi) 0.75 0.5+ -- Tertiary colors orange, rose, chartreuse, aquamarine, violet, azure :: Color-orange     = fromHSL ( 1/6 * pi) 0.75 0.5-chartreuse = fromHSL ( 3/6 * pi) 0.75 0.5-aquamarine = fromHSL ( 5/6 * pi) 0.75 0.5-azure      = fromHSL ( 7/6 * pi) 0.75 0.5-violet     = fromHSL ( 9/6 * pi) 0.75 0.5-rose       = fromHSL (11/6 * pi) 0.75 0.5+orange = fromHSL (1 / 6 * pi) 0.75 0.5 +chartreuse = fromHSL (3 / 6 * pi) 0.75 0.5++aquamarine = fromHSL (5 / 6 * pi) 0.75 0.5++azure = fromHSL (7 / 6 * pi) 0.75 0.5++violet = fromHSL (9 / 6 * pi) 0.75 0.5++rose = fromHSL (11 / 6 * pi) 0.75 0.5+ -- Other common colors and color names-brown      = fromHSL (1/6   * pi) 0.5  0.5-purple     = fromHSL (1.556 * pi) 0.75 0.5-pink       = fromHSL (23/12 * pi) 0.75 0.75+brown = fromHSL (1 / 6 * pi) 0.5 0.5 +purple = violet++pink = lighter 0.25 rose+ mixed :: Color -> Color -> Color-mixed (RGBA r1 g1 b1 a1) (RGBA r2 g2 b2 a2)-  | a1 + a2 == 0 = RGBA 0 0 0 0-  | otherwise    = RGBA r g b a-  where r = sqrt(r1^2 * a1 + r2^2 * a2 / (a1 + a2))-        g = sqrt(g1^2 * a1 + g2^2 * a2 / (a1 + a2))-        b = sqrt(b1^2 * a1 + b2^2 * a2 / (a1 + a2))-        a = (a1 + a2) / 2+mixed (fenceColor -> RGBA r1 g1 b1 a1) (fenceColor -> RGBA r2 g2 b2 a2)+    | a1 + a2 == 0 = RGBA 0 0 0 0+    | otherwise = RGBA r g b a+  where+    r = sqrt ((r1 ^ 2 * a1 + r2 ^ 2 * a2) / (a1 + a2))+    g = sqrt ((g1 ^ 2 * a1 + g2 ^ 2 * a2) / (a1 + a2))+    b = sqrt ((b1 ^ 2 * a1 + b2 ^ 2 * a2) / (a1 + a2))+    a = (a1 + a2) / 2  -- Helper function that sets the alpha of the second color to that -- of the first sameAlpha :: Color -> Color -> Color-sameAlpha (RGBA r1 g1 b1 a1) (RGBA r2 g2 b2 a2) = RGBA r2 g2 b2 a1+sameAlpha (fenceColor -> RGBA r1 g1 b1 a1) (fenceColor -> RGBA r2 g2 b2 a2) =+    RGBA r2 g2 b2 a1  lighter :: Double -> Color -> Color-lighter d c = sameAlpha c $ fromHSL (hue c) (saturation c) (fence (luminosity c + d))-  where fence x = max 0 (min 1 x)+lighter d c =+    sameAlpha c $ fromHSL (hue c) (saturation c) (fence (luminosity c + d))  light :: Color -> Color light = lighter 0.15@@ -74,8 +149,8 @@ dark = darker 0.15  brighter :: Double -> Color -> Color-brighter d c = sameAlpha c $ fromHSL (hue c) (fence (saturation c + d)) (luminosity c)-  where fence x = max 0 (min 1 x)+brighter d c =+    sameAlpha c $ fromHSL (hue c) (fence (saturation c + d)) (luminosity c)  bright :: Color -> Color bright = brighter 0.25@@ -87,47 +162,52 @@ dull = duller 0.25  translucent :: Color -> Color-translucent (RGBA r g b a) = RGBA r g b (a/2)+translucent (fenceColor -> RGBA r g b a) = RGBA r g b (a / 2)  gray, grey :: Double -> Color gray = grey-grey k = RGBA k k k 1 +grey (fence -> k) = RGBA k k k 1++-- | An infinite list of colors.+assortedColors :: [Color]+assortedColors = red : green : blue : more+  where+    more =+        [ fromHSL hue 0.75 0.5+        | denom <- doublesOf 6+        , numer <- shuffleSeed denom [1,3 .. denom]+        , let hue = fromIntegral numer * 2 * pi / fromIntegral denom+        ]+    doublesOf n = n : doublesOf (2 * n)+    shuffleSeed k xs = shuffle' xs (length xs) (mkStdGen k)+ hue :: Color -> Double-hue (RGBA r g b a)-  | hi == lo           = 0-  | r  == hi && g >= b = (g - b) / (hi - lo) * pi / 3-  | r  == hi           = (g - b) / (hi - lo) * pi / 3 + 2 * pi-  | g  == hi           = (b - r) / (hi - lo) * pi / 3 + 2/3 * pi-  | otherwise          = (r - g) / (hi - lo) * pi / 3 + 4/3 * pi-  where hi = max r (max g b)-        lo = min r (min g b)+hue (fenceColor -> RGBA r g b a)+    | hi - lo < epsilon = 0+    | r == hi && g >= b = (g - b) / (hi - lo) * pi / 3+    | r == hi = (g - b) / (hi - lo) * pi / 3 + 2 * pi+    | g == hi = (b - r) / (hi - lo) * pi / 3 + 2 / 3 * pi+    | otherwise = (r - g) / (hi - lo) * pi / 3 + 4 / 3 * pi+  where+    hi = max r (max g b)+    lo = min r (min g b)+    epsilon = 0.000001  saturation :: Color -> Double-saturation (RGBA r g b a)-  | hi == lo  = 0-  | otherwise = (hi - lo) / (1 - abs (hi + lo - 1))-  where hi = max r (max g b)-        lo = min r (min g b)+saturation (fenceColor -> RGBA r g b a)+    | hi - lo < epsilon = 0+    | otherwise = (hi - lo) / (1 - abs (hi + lo - 1))+  where+    hi = max r (max g b)+    lo = min r (min g b)+    epsilon = 0.000001  luminosity :: Color -> Double-luminosity (RGBA r g b a) = (lo + hi) / 2-  where hi = max r (max g b)-        lo = min r (min g b)+luminosity (fenceColor -> RGBA r g b a) = (lo + hi) / 2+  where+    hi = max r (max g b)+    lo = min r (min g b) --- Based on the algorithm from the CSS3 specification.-fromHSL :: Double -> Double -> Double -> Color-fromHSL h s l = RGBA r g b 1-  where m1             = l * 2 - m2-        m2 | l <= 0.5  = l * (s + 1)-           | otherwise = l + s - l * s-        r              = convert m1 m2 (h / 2 / pi + 1/3)-        g              = convert m1 m2 (h / 2 / pi      )-        b              = convert m1 m2 (h / 2 / pi - 1/3)-        convert m1 m2 h-          | h < 0     = convert m1 m2 (h + 1)-          | h > 1     = convert m1 m2 (h - 1)-          | h * 6 < 1 = m1 + (m2 - m1) * h * 6-          | h * 2 < 1 = m2-          | h * 3 < 2 = m1 + (m2 - m1) * (2/3 - h) * 6-          | otherwise = m1+alpha :: Color -> Double+alpha (RGBA r g b a) = fence a

@@ -1,1336 +1,2081 @@-{-# LANGUAGE CPP                      #-}-{-# LANGUAGE DefaultSignatures        #-}-{-# LANGUAGE DeriveGeneric            #-}-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE GADTs                    #-}-{-# LANGUAGE JavaScriptFFI            #-}-{-# LANGUAGE KindSignatures           #-}-{-# LANGUAGE LambdaCase               #-}-{-# LANGUAGE MultiWayIf               #-}-{-# LANGUAGE OverloadedStrings        #-}-{-# LANGUAGE PatternGuards            #-}-{-# LANGUAGE RecordWildCards          #-}-{-# LANGUAGE ScopedTypeVariables      #-}-{-# LANGUAGE StandaloneDeriving       #-}-{-# LANGUAGE DataKinds                #-}--{--  Copyright 2016 The CodeWorld Authors. All rights reserved.--  Licensed under the Apache License, Version 2.0 (the "License");-  you may not use this file except in compliance with the License.-  You may obtain a copy of the License at--      http://www.apache.org/licenses/LICENSE-2.0--  Unless required by applicable law or agreed to in writing, software-  distributed under the License is distributed on an "AS IS" BASIS,-  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.-  See the License for the specific language governing permissions and-  limitations under the License.--}--module CodeWorld.Driver (-    drawingOf,-    animationOf,-    simulationOf,-    interactionOf,-    collaborationOf,-    unsafeCollaborationOf,-    trace-    ) where--import           CodeWorld.Color-import           CodeWorld.Event-import           CodeWorld.Picture-import           CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)-import qualified CodeWorld.CollaborationUI as CUI-import           Control.Concurrent-import           Control.Concurrent.MVar-import           Control.Concurrent.Chan-import           Control.Exception-import           Control.Monad-import           Control.Monad.Trans (liftIO)-import           Data.Char (chr)-import           Data.List (zip4)-import           Data.Maybe (fromMaybe, mapMaybe)-import           Data.Monoid-import           Data.Serialize-import           Data.Serialize.Text-import qualified Data.Text as T-import           Data.Text (Text, singleton, pack)-import           GHC.Fingerprint.Type-import           GHC.Generics-import           GHC.StaticPtr-import           Numeric-import           System.Environment-import           System.Mem.StableName-import           Text.Read-import           System.Random--#ifdef ghcjs_HOST_OS--import           CodeWorld.Prediction-import           CodeWorld.Message-import           Data.Hashable-import           Data.IORef-import           Data.JSString.Text-import qualified Data.JSString-import           Data.Time.Clock-import           Data.Word-import           GHCJS.DOM-import           GHCJS.DOM.NonElementParentNode-import           GHCJS.DOM.GlobalEventHandlers-import           GHCJS.DOM.Window as Window-import           GHCJS.DOM.Document-import qualified GHCJS.DOM.ClientRect as ClientRect-import           GHCJS.DOM.Element-import           GHCJS.DOM.EventM-import           GHCJS.DOM.MouseEvent-import           GHCJS.DOM.Types (Element, unElement)-import           GHCJS.Foreign-import           GHCJS.Marshal-import           GHCJS.Marshal.Pure-import           GHCJS.Types-import           JavaScript.Web.AnimationFrame-import qualified JavaScript.Web.Canvas as Canvas-import qualified JavaScript.Web.Canvas.Internal as Canvas-import qualified JavaScript.Web.Location as Loc-import qualified JavaScript.Web.MessageEvent as WS-import qualified JavaScript.Web.WebSocket as WS-import           System.IO.Unsafe--#else--import           Data.Time.Clock-import qualified Debug.Trace-import qualified Graphics.Blank as Canvas-import           Graphics.Blank (Canvas)-import           System.IO-import           Text.Printf--#endif------------------------------------------------------------------------------------- The common interface, provided by both implementations below.---- | Draws a 'Picture'.  This is the simplest CodeWorld entry point.-drawingOf :: Picture -> IO ()---- | Shows an animation, with a picture for each time given by the parameter.-animationOf :: (Double -> Picture) -> IO ()---- | Shows a simulation, which is essentially a continuous-time dynamical--- system described by an initial value and step function.-simulationOf :: world -> (Double -> world -> world) -> (world -> Picture) -> IO ()---- | Runs an interactive event-driven CodeWorld program.  This is a--- generalization of simulations that can respond to events like key presses--- and mouse movement.-interactionOf :: world-              -> (Double -> world -> world)-              -> (Event -> world -> world)-              -> (world -> Picture)-              -> IO ()---- | Runs an interactive multi-user CodeWorld program, involving multiple--- participants over the internet.-collaborationOf :: Int-                -> StaticPtr (StdGen -> world)-                -> StaticPtr (Double -> world -> world)-                -> StaticPtr (Int -> Event -> world -> world)-                -> StaticPtr (Int -> world -> Picture)-                -> IO ()---- | A version of 'collaborationOf' that avoids static pointers, and does not--- check for consistent parameters.-unsafeCollaborationOf :: Int-                      -> (StdGen -> world)-                      -> (Double -> world -> world)-                      -> (Int -> Event -> world -> world)-                      -> (Int -> world -> Picture)-                      -> IO ()---- | Prints a debug message to the CodeWorld console when a value is forced.--- This is equivalent to the similarly named function in `Debug.Trace`, except--- that it uses the CodeWorld console instead of standard output.-trace :: Text -> a -> a------------------------------------------------------------------------------------- Draw state.  An affine transformation matrix, plus a Bool indicating whether--- a color has been chosen yet.--type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color)--initialDS :: DrawState-initialDS = (1, 0, 0, 1, 0, 0, Nothing)--translateDS :: Double -> Double -> DrawState -> DrawState-translateDS x y (a,b,c,d,e,f,hc) =-    (a, b, c, d, a*25*x + c*25*y + e, b*25*x + d*25*y + f, hc)--scaleDS :: Double -> Double -> DrawState -> DrawState-scaleDS x y (a,b,c,d,e,f,hc) =-    (x*a, x*b, y*c, y*d, e, f, hc)--rotateDS :: Double -> DrawState -> DrawState-rotateDS r (a,b,c,d,e,f,hc) =-    (a * cos r + c * sin r,-     b * cos r + d * sin r,-     c * cos r - a * sin r,-     d * cos r - b * sin r,-     e, f, hc)--setColorDS :: Color -> DrawState -> DrawState-setColorDS col (a,b,c,d,e,f,Nothing) = (a,b,c,d,e,f,Just col)-setColorDS _ (a,b,c,d,e,f,Just col) = (a,b,c,d,e,f,Just col)--getColorDS :: DrawState -> Maybe Color-getColorDS (a,b,c,d,e,f,col) = col------------------------------------------------------------------------------------- GHCJS implementation of drawing--#ifdef ghcjs_HOST_OS--foreign import javascript unsafe "$1.drawImage($2, $3, $4, $5, $6);"-    js_canvasDrawImage :: Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()--foreign import javascript unsafe "$1.getContext('2d', { alpha: false })"-    js_getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context--foreign import javascript unsafe "performance.now()"-    js_getHighResTimestamp :: IO Double--canvasFromElement :: Element -> Canvas.Canvas-canvasFromElement = Canvas.Canvas . unElement--elementFromCanvas :: Canvas.Canvas -> Element-elementFromCanvas = pFromJSVal . jsval--getTime :: IO Double-getTime = (/ 1000) <$> js_getHighResTimestamp--nextFrame :: IO Double-nextFrame = waitForAnimationFrame >> getTime--withDS :: Canvas.Context -> DrawState -> IO () -> IO ()-withDS ctx (ta,tb,tc,td,te,tf,col) action = do-    Canvas.save ctx-    Canvas.transform ta tb tc td te tf ctx-    Canvas.beginPath ctx-    action-    Canvas.restore ctx--applyColor :: Canvas.Context -> DrawState -> IO ()-applyColor ctx ds = case getColorDS ds of-    Nothing -> do-      Canvas.strokeStyle 0 0 0 1 ctx-      Canvas.fillStyle 0 0 0 1 ctx-    Just (RGBA r g b a) -> do-      Canvas.strokeStyle (round $ r * 255)-                         (round $ g * 255)-                         (round $ b * 255)-                         a ctx-      Canvas.fillStyle (round $ r * 255)-                       (round $ g * 255)-                       (round $ b * 255)-                       a ctx--foreign import javascript unsafe "$1.globalCompositeOperation = $2"-    js_setGlobalCompositeOperation :: Canvas.Context -> JSString -> IO ()--drawCodeWorldLogo :: Canvas.Context -> DrawState -> Int -> Int -> Int -> Int -> IO ()-drawCodeWorldLogo ctx ds x y w h = do-    Just doc <- currentDocument-    Just canvas <- getElementById doc ("cwlogo" :: JSString)-    case getColorDS ds of-        Nothing -> js_canvasDrawImage ctx canvas x y w h-        Just (RGBA r g b a) -> do-            -- This is a tough case.  The best we can do is to allocate an-            -- offscreen buffer as a temporary.-            buf <- Canvas.create w h-            bufctx <- js_getCodeWorldContext buf-            applyColor bufctx ds-            Canvas.fillRect 0 0 (fromIntegral w) (fromIntegral h) bufctx-            js_setGlobalCompositeOperation bufctx "destination-in"-            js_canvasDrawImage bufctx canvas 0 0 w h-            js_canvasDrawImage ctx (elementFromCanvas buf) x y w h--followPath :: Canvas.Context -> [Point] -> Bool -> Bool -> IO ()-followPath ctx [] closed _ = return ()-followPath ctx [p1] closed _ = return ()-followPath ctx ((sx,sy):ps) closed False = do-    Canvas.moveTo (25 * sx) (25 * sy) ctx-    forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x) (25 * y) ctx-    when closed $ Canvas.closePath ctx-followPath ctx [p1, p2] False True = followPath ctx [p1, p2] False False-followPath ctx ps False True = do-    let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps-        dprev = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-        dnext = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-        p     = dprev / (dprev + dnext)-        cx    = x2 + p * (x1 - x3) / 2-        cy    = y2 + p * (y1 - y3) / 2-     in do Canvas.moveTo (25 * x1) (25 * y1) ctx-           Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x2) (25 * y2) ctx-    forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $-        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->-            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)-                p   = d1 / (d1 + d2)-                r   = d1 / (dp + d1)-                cx1 = x2 + r * (x3 - x1) / 2-                cy1 = y2 + r * (y3 - y1) / 2-                cx2 = x3 + p * (x2 - x4) / 2-                cy2 = y3 + p * (y2 - y4) / 2-            in  Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)-                                     (25 * x3) (25 * y3) ctx-    let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps-        dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-        d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-        r  = d1 / (dp + d1)-        cx = x2 + r * (x3 - x1) / 2-        cy = y2 + r * (y3 - y1) / 2-     in Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x3) (25 * y3) ctx-followPath ctx ps@(_:(sx,sy):_) True True = do-    Canvas.moveTo (25 * sx) (25 * sy) ctx-    let rep = cycle ps-    forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $-        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->-            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)-                p   = d1 / (d1 + d2)-                r   = d1 / (dp + d1)-                cx1 = x2 + r * (x3 - x1) / 2-                cy1 = y2 + r * (y3 - y1) / 2-                cx2 = x3 + p * (x2 - x4) / 2-                cy2 = y3 + p * (y2 - y4) / 2-            in  Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)-                                     (25 * x3) (25 * y3) ctx-    Canvas.closePath ctx--drawFigure :: Canvas.Context -> DrawState -> Double -> IO () -> IO ()-drawFigure ctx ds w figure = do-    withDS ctx ds $ do-        figure-        when (w /= 0) $ do-            Canvas.lineWidth (25 * w) ctx-            applyColor ctx ds-            Canvas.stroke ctx-    when (w == 0) $ do-        Canvas.lineWidth 1 ctx-        applyColor ctx ds-        Canvas.stroke ctx--fontString :: TextStyle -> Font -> JSString-fontString style font = stylePrefix style <> "25px " <> fontName font-  where stylePrefix Plain        = ""-        stylePrefix Bold         = "bold "-        stylePrefix Italic       = "italic "-        fontName SansSerif       = "sans-serif"-        fontName Serif           = "serif"-        fontName Monospace       = "monospace"-        fontName Handwriting     = "cursive"-        fontName Fancy           = "fantasy"-        fontName (NamedFont txt) = "\"" <> textToJSString (T.filter (/= '"') txt) <> "\""--drawPicture :: Canvas.Context -> DrawState -> Picture -> IO ()-drawPicture ctx ds (Polygon ps smooth) = do-    withDS ctx ds $ followPath ctx ps True smooth-    applyColor ctx ds-    Canvas.fill ctx-drawPicture ctx ds (Path ps w closed smooth) = do-    drawFigure ctx ds w $ followPath ctx ps closed smooth-drawPicture ctx ds (Sector b e r) = withDS ctx ds $ do-    Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx-    Canvas.lineTo 0 0 ctx-    applyColor ctx ds-    Canvas.fill ctx-drawPicture ctx ds (Arc b e r w) = do-    drawFigure ctx ds w $ do-        Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx-drawPicture ctx ds (Text sty fnt txt) = withDS ctx ds $ do-    Canvas.scale 1 (-1) ctx-    applyColor ctx ds-    Canvas.font (fontString sty fnt) ctx-    Canvas.fillText (textToJSString txt) 0 0 ctx-drawPicture ctx ds Logo = withDS ctx ds $ do-    Canvas.scale 1 (-1) ctx-    drawCodeWorldLogo ctx ds (-225) (-50) 450 100-drawPicture ctx ds (Color col p)     = drawPicture ctx (setColorDS col ds) p-drawPicture ctx ds (Translate x y p) = drawPicture ctx (translateDS x y ds) p-drawPicture ctx ds (Scale x y p)     = drawPicture ctx (scaleDS x y ds) p-drawPicture ctx ds (Rotate r p)      = drawPicture ctx (rotateDS r ds) p-drawPicture ctx ds (Pictures ps)     = mapM_ (drawPicture ctx ds) (reverse ps)--drawFrame :: Canvas.Context -> Picture -> IO ()-drawFrame ctx pic = do-    Canvas.fillStyle 255 255 255 1 ctx-    Canvas.fillRect (-250) (-250) 500 500 ctx-    drawPicture ctx initialDS pic--setupScreenContext :: Element -> ClientRect.ClientRect -> IO Canvas.Context-setupScreenContext canvas rect = do-    cw <- ClientRect.getWidth rect-    ch <- ClientRect.getHeight rect-    ctx <- js_getCodeWorldContext (canvasFromElement canvas)-    Canvas.save ctx-    Canvas.translate (realToFrac cw / 2) (realToFrac ch / 2) ctx-    Canvas.scale (realToFrac cw / 500) (- realToFrac ch / 500) ctx-    Canvas.lineWidth 0 ctx-    Canvas.textAlign Canvas.Center ctx-    Canvas.textBaseline Canvas.Middle ctx-    return ctx--setCanvasSize :: Element -> Element -> IO ()-setCanvasSize target canvas = do-    rect <- getBoundingClientRect canvas-    cx <- ClientRect.getWidth rect-    cy <- ClientRect.getHeight rect-    setAttribute target ("width" :: JSString) (show (round cx))-    setAttribute target ("height" :: JSString) (show (round cy))--display :: Picture -> IO ()-display pic = do-    Just window <- currentWindow-    Just doc <- currentDocument-    Just canvas <- getElementById doc ("screen" :: JSString)-    on window resize $ liftIO (draw canvas)-    draw canvas-  where-    draw canvas = do-        setCanvasSize canvas canvas-        rect <- getBoundingClientRect canvas-        ctx <- setupScreenContext canvas rect-        drawFrame ctx pic-        Canvas.restore ctx--drawingOf pic = display pic `catch` reportError-------------------------------------------------------------------------------------- Stand-alone implementation of drawing--#else--withDS :: DrawState -> Canvas () -> Canvas ()-withDS (ta,tb,tc,td,te,tf,col) action =-    Canvas.saveRestore $ do-        Canvas.transform (ta, tb, tc, td, te, tf)-        Canvas.beginPath ()-        action--applyColor :: DrawState -> Canvas ()-applyColor ds = case getColorDS ds of-    Nothing -> do-      Canvas.strokeStyle "black"-      Canvas.fillStyle   "black"-    Just (RGBA r g b a) -> do-      let style = pack $ printf "rgba(%.0f,%.0f,%.0f,%f)" (r*255) (g*255) (b*255) a-      Canvas.strokeStyle style-      Canvas.fillStyle   style---drawFigure :: DrawState -> Double -> Canvas () -> Canvas ()-drawFigure ds w figure = do-    withDS ds $ do-        figure-        when (w /= 0) $ do-            Canvas.lineWidth (25 * w)-            applyColor ds-            Canvas.stroke ()-    when (w == 0) $ do-        Canvas.lineWidth 1-        applyColor ds-        Canvas.stroke ()--followPath :: [Point] -> Bool -> Bool -> Canvas ()-followPath [] closed _ = return ()-followPath [p1] closed _ = return ()-followPath ((sx,sy):ps) closed False = do-    Canvas.moveTo (25 * sx, 25 * sy)-    forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x, 25 * y)-    when closed $ Canvas.closePath ()-followPath [p1, p2] False True = followPath [p1, p2] False False-followPath ps False True = do-    let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps-        dprev = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-        dnext = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-        p     = dprev / (dprev + dnext)-        cx    = x2 + p * (x1 - x3) / 2-        cy    = y2 + p * (y1 - y3) / 2-     in do Canvas.moveTo (25 * x1, 25 * y1)-           Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x2, 25 * y2)-    forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $-        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->-            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)-                p   = d1 / (d1 + d2)-                r   = d1 / (dp + d1)-                cx1 = x2 + r * (x3 - x1) / 2-                cy1 = y2 + r * (y3 - y1) / 2-                cx2 = x3 + p * (x2 - x4) / 2-                cy2 = y3 + p * (y2 - y4) / 2-            in  Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2-                                     , 25 * x3,  25 * y3)-    let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps-        dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-        d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-        r  = d1 / (dp + d1)-        cx = x2 + r * (x3 - x1) / 2-        cy = y2 + r * (y3 - y1) / 2-     in Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x3, 25 * y3)-followPath ps@(_:(sx,sy):_) True True = do-    Canvas.moveTo (25 * sx, 25 * sy)-    let rep = cycle ps-    forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $-        \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->-            let dp  = sqrt ((x2 - x1)^2 + (y2 - y1)^2)-                d1  = sqrt ((x3 - x2)^2 + (y3 - y2)^2)-                d2  = sqrt ((x4 - x3)^2 + (y4 - y3)^2)-                p   = d1 / (d1 + d2)-                r   = d1 / (dp + d1)-                cx1 = x2 + r * (x3 - x1) / 2-                cy1 = y2 + r * (y3 - y1) / 2-                cx2 = x3 + p * (x2 - x4) / 2-                cy2 = y3 + p * (y2 - y4) / 2-            in  Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2-                                     , 25 * x3, 25 * y3)-    Canvas.closePath ()---fontString :: TextStyle -> Font -> Text-fontString style font = stylePrefix style <> "25px " <> fontName font-  where stylePrefix Plain        = ""-        stylePrefix Bold         = "bold "-        stylePrefix Italic       = "italic "-        fontName SansSerif       = "sans-serif"-        fontName Serif           = "serif"-        fontName Monospace       = "monospace"-        fontName Handwriting     = "cursive"-        fontName Fancy           = "fantasy"-        fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\""--drawPicture :: DrawState -> Picture -> Canvas ()-drawPicture ds (Polygon ps smooth) = do-    withDS ds $ followPath ps True smooth-    applyColor ds-    Canvas.fill ()-drawPicture ds (Path ps w closed smooth) = do-    drawFigure ds w $ followPath ps closed smooth-drawPicture ds (Sector b e r) = withDS ds $ do-    Canvas.arc (0, 0, 25 * abs r, b, e,  b > e)-    Canvas.lineTo (0, 0)-    applyColor ds-    Canvas.fill ()-drawPicture ds (Arc b e r w) = do-    drawFigure ds w $ do-        Canvas.arc (0, 0, 25 * abs r, b, e, b > e)-drawPicture ds (Text sty fnt txt) = withDS ds $ do-    Canvas.scale (1, -1)-    applyColor ds-    Canvas.font (fontString sty fnt)-    Canvas.fillText (txt, 0, 0)-drawPicture ds Logo              = return () -- Unimplemented-drawPicture ds (Color col p)     = drawPicture (setColorDS col ds) p-drawPicture ds (Translate x y p) = drawPicture (translateDS x y ds) p-drawPicture ds (Scale x y p)     = drawPicture (scaleDS x y ds) p-drawPicture ds (Rotate r p)      = drawPicture (rotateDS r ds) p-drawPicture ds (Pictures ps)     = mapM_ (drawPicture ds) (reverse ps)--setupScreenContext :: (Int, Int) -> Canvas ()-setupScreenContext (cw, ch) = do-    -- blank before transformation (canvas might be non-sqare)-    Canvas.fillStyle "white"-    Canvas.fillRect (0,0,fromIntegral cw,fromIntegral ch)--    Canvas.translate (realToFrac cw / 2, realToFrac ch / 2)-    let s = min (realToFrac cw / 500) (realToFrac ch / 500)-    Canvas.scale (s, -s)-    Canvas.lineWidth 0-    Canvas.textAlign Canvas.CenterAnchor-    Canvas.textBaseline Canvas.MiddleBaseline--type Port = Int--readPortFromEnv :: String -> Port -> IO Port-readPortFromEnv envName defaultPort = do-    ms <- lookupEnv envName-    return (fromMaybe defaultPort (ms >>= readMaybe))--runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO ()-runBlankCanvas act = do-    port <- readPortFromEnv "CODEWORLD_API_PORT" 3000-    let options = (fromIntegral port) { Canvas.events =-            [ "mousedown", "mouseup", "mousemove", "keydown", "keyup"]-        }-    putStrLn $ printf "Open me on http://127.0.0.1:%d/" (Canvas.port options)-    Canvas.blankCanvas options $ \context -> do-        putStrLn "Program is starting..."-        act context--display :: Picture -> IO ()-display pic = runBlankCanvas $ \context ->-    Canvas.send context $ Canvas.saveRestore $ do-        let rect = (Canvas.width context, Canvas.height context)-        setupScreenContext rect-        drawPicture initialDS pic--drawingOf pic = display pic `catch` reportError-#endif-------------------------------------------------------------------------------------- Common event handling and core interaction code--keyCodeToText :: Word -> Text-keyCodeToText n = case n of-    _ | n >= 47  && n <= 90  -> fromAscii n-    _ | n >= 96  && n <= 105 -> fromNum (n - 96)-    _ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111)-    3                        -> "Cancel"-    6                        -> "Help"-    8                        -> "Backspace"-    9                        -> "Tab"-    12                       -> "5"-    13                       -> "Enter"-    16                       -> "Shift"-    17                       -> "Ctrl"-    18                       -> "Alt"-    19                       -> "Break"-    20                       -> "CapsLock"-    27                       -> "Esc"-    32                       -> " "-    33                       -> "PageUp"-    34                       -> "PageDown"-    35                       -> "End"-    36                       -> "Home"-    37                       -> "Left"-    38                       -> "Up"-    39                       -> "Right"-    40                       -> "Down"-    42                       -> "*"-    43                       -> "+"-    44                       -> "PrintScreen"-    45                       -> "Insert"-    46                       -> "Delete"-    106                      -> "*"-    107                      -> "+"-    108                      -> "Separator"-    109                      -> "-"-    110                      -> "."-    111                      -> "/"-    144                      -> "NumLock"-    145                      -> "ScrollLock"-    186                      -> ";"-    187                      -> "="-    188                      -> ","-    189                      -> "-"-    190                      -> "."-    191                      -> "/"-    192                      -> "`"-    219                      -> "["-    220                      -> "\\"-    221                      -> "]"-    222                      -> "'"-    _                        -> "Unknown:" <> fromNum n-  where fromAscii n = singleton (chr (fromIntegral n))-        fromNum   n = pack (show (fromIntegral n))--isUniversallyConstant :: (a -> s -> s) -> s -> IO Bool-isUniversallyConstant f old = falseOr $ do-    oldName <- makeStableName old-    genName <- makeStableName $! (f undefined old)-    return (genName == oldName)-  where falseOr x = x `catch` \(e :: SomeException) -> return False--applyIfModifying :: (s -> IO s) -> s -> IO (Maybe s)-applyIfModifying f s0 = do-    oldName <- makeStableName $! s0-    s1      <- f s0-    newName <- makeStableName $! s1-    if newName /= oldName then return (Just s1)-                          else return Nothing--modifyMVarIfNeeded :: MVar s -> (s -> IO s) -> IO Bool-modifyMVarIfNeeded var f = modifyMVar var $ \s0 -> do-    ms1 <- applyIfModifying f s0-    case ms1 of Nothing -> return (s0, False)-                Just s1 -> return (s1, True)--data GameToken-    = FullToken {-          tokenDeployHash :: Text,-          tokenNumPlayers :: Int,-          tokenInitial :: StaticKey,-          tokenStep :: StaticKey,-          tokenEvent :: StaticKey,-          tokenDraw :: StaticKey-      }-    | PartialToken {-          tokenDeployHash :: Text-      }-    | NoToken-    deriving Generic--deriving instance Generic Fingerprint-instance Serialize Fingerprint-instance Serialize GameToken------------------------------------------------------------------------------------- GHCJS event handling and core interaction code--#ifdef ghcjs_HOST_OS--getMousePos :: IsMouseEvent e => Element -> EventM w e Point-getMousePos canvas = do-    (ix, iy) <- mouseClientXY-    liftIO $ do-        rect <- getBoundingClientRect canvas-        cx <- ClientRect.getLeft rect-        cy <- ClientRect.getTop rect-        cw <- ClientRect.getWidth rect-        ch <- ClientRect.getHeight rect-        return (20 * fromIntegral (ix - round cx) / realToFrac cw - 10,-                20 * fromIntegral (round cy - iy) / realToFrac cw + 10)--fromButtonNum :: Word -> Maybe MouseButton-fromButtonNum 0 = Just LeftButton-fromButtonNum 1 = Just MiddleButton-fromButtonNum 2 = Just RightButton-fromButtonNum _ = Nothing--onEvents :: Element -> (Event -> IO ()) -> IO ()-onEvents canvas handler = do-    Just window <- currentWindow-    on window keyDown $ do-        code <- uiKeyCode-        let keyName = keyCodeToText code-        when (keyName /= "") $ do-            liftIO $ handler (KeyPress keyName)-            preventDefault-            stopPropagation-    on window keyUp $ do-        code <- uiKeyCode-        let keyName = keyCodeToText code-        when (keyName /= "") $ do-            liftIO $ handler (KeyRelease keyName)-            preventDefault-            stopPropagation-    on window mouseDown $ do-        button <- mouseButton-        case fromButtonNum button of-            Nothing  -> return ()-            Just btn -> do-                pos <- getMousePos canvas-                liftIO $ handler (MousePress btn pos)-    on window mouseUp $ do-        button <- mouseButton-        case fromButtonNum button of-            Nothing  -> return ()-            Just btn -> do-                pos <- getMousePos canvas-                liftIO $ handler (MouseRelease btn pos)-    on window mouseMove $ do-        pos <- getMousePos canvas-        liftIO $ handler (MouseMovement pos)-    return ()--encodeEvent :: (Timestamp, Maybe Event) -> String-encodeEvent = show--decodeEvent :: String -> Maybe (Timestamp, Maybe Event)-decodeEvent = readMaybe--data GameState s-    = Main       (UIState SMain)-    | Connecting WS.WebSocket (UIState SConnect)-    | Waiting    WS.WebSocket GameId PlayerId (UIState SWait)-    | Running    WS.WebSocket GameId Timestamp PlayerId (Future s)--isRunning :: GameState s -> Bool-isRunning Running{} = True-isRunning _         = False--gameTime :: GameState s -> Timestamp -> Double-gameTime (Running _ _ tstart _ _) t = t - tstart-gameTime _ _                        = 0---- It's worth trying to keep the canonical animation rate exactly representable--- as a float, to minimize the chance of divergence due to rounding error.-gameRate :: Double-gameRate = 1/16--gameStep :: (Double -> s -> s) -> Double -> GameState s -> GameState s-gameStep _    t (Main s)-    = Main (CUI.step t s)-gameStep _    t (Connecting ws s)-    = Connecting ws (CUI.step t s)-gameStep _    t (Waiting ws gid pid s)-    = Waiting ws gid pid (CUI.step t s)-gameStep step t (Running ws gid tstart pid s)-    = Running ws gid tstart pid (currentTimePasses step gameRate (t - tstart) s)--gameDraw :: (Double -> s -> s)-         -> (PlayerId -> s -> Picture)-         -> GameState s-         -> Timestamp-         -> Picture-gameDraw _    _    (Main s)                   _ = CUI.picture s-gameDraw _    _    (Connecting _ s)           _ = CUI.picture s-gameDraw _    _    (Waiting _ _ _ s)          _ = CUI.picture s-gameDraw step draw (Running _ _ tstart pid s) t = draw pid (currentState step gameRate (t - tstart) s)--handleServerMessage :: Int-                    -> (StdGen -> s)-                    -> (Double -> s -> s)-                    -> (PlayerId -> Event -> s -> s)-                    -> MVar (GameState s)-                    -> ServerMessage-                    -> IO ()-handleServerMessage numPlayers initial stepHandler eventHandler gsm sm = do-    modifyMVar_ gsm $ \gs -> do-        t <- getTime-        case (sm, gs) of-            (GameAborted,         _) ->-                return initialGameState-            (JoinedAs pid gid,    Connecting ws s) ->-                return (Waiting ws gid pid (CUI.startWaiting gid s))-            (PlayersWaiting m n,  Waiting ws gid pid s) ->-                return (Waiting ws gid pid (CUI.updatePlayers n m s))-            (Started,             Waiting ws gid pid _) ->-                return (Running ws gid t pid (initFuture (initial (mkStdGen (hash gid))) numPlayers))-            (OutEvent pid eo,     Running ws gid tstart mypid s) ->-                case decodeEvent eo of-                    Just (t',event) ->-                        let ours   = pid == mypid-                            func   = eventHandler pid <$> event -- might be a ping (Nothing)-                            result | ours      = s -- we already took care of our events-                                   | otherwise = addEvent stepHandler gameRate mypid t' func s-                        in  return (Running ws gid tstart mypid result)-                    Nothing -> return (Running ws gid tstart mypid s)-            _ -> return gs-    return ()--gameHandle :: Int-            -> (StdGen -> s)-            -> (Double -> s -> s)-            -> (PlayerId -> Event -> s -> s)-            -> GameToken-            -> MVar (GameState s)-            -> Event-            -> IO ()-gameHandle numPlayers initial stepHandler eventHandler token gsm event = do-    gs <- takeMVar gsm-    case gs of-        Main s -> case CUI.event event s of-            ContinueMain s' -> do-                putMVar gsm (Main s')-            Create s' -> do-                ws <- connectToGameServer (handleServerMessage numPlayers initial stepHandler eventHandler gsm)-                sendClientMessage ws (NewGame numPlayers (encode token))-                putMVar gsm (Connecting ws s')-            Join gid s' -> do-                ws <- connectToGameServer (handleServerMessage numPlayers initial stepHandler eventHandler gsm)-                sendClientMessage ws (JoinGame gid (encode token))-                putMVar gsm (Connecting ws s')-        Connecting ws s -> case CUI.event event s of-            ContinueConnect s' -> do-                putMVar gsm (Connecting ws s')-            CancelConnect s' -> do-                WS.close Nothing Nothing ws-                putMVar gsm (Main s')-        Waiting ws gid pid s -> case CUI.event event s of-            ContinueWait s' -> do-                putMVar gsm (Waiting ws gid pid s')-            CancelWait s' -> do-                WS.close Nothing Nothing ws-                putMVar gsm (Main s')--        Running ws gid tstart pid f -> do-            t   <- getTime-            let gameState0 = currentState stepHandler gameRate (t - tstart) f-            let eventFun = eventHandler pid event-            ms1 <- (return . eventFun) `applyIfModifying` gameState0-            case ms1 of-                Nothing -> do-                    putMVar gsm gs-                Just s1 -> do-                    sendClientMessage ws (InEvent (encodeEvent (gameTime gs t, Just event)))-                    let f1 = addEvent stepHandler gameRate pid (t - tstart) (Just eventFun) f-                    putMVar gsm (Running ws gid tstart pid f1)--getWebSocketURL :: IO JSString-getWebSocketURL = do-    loc      <- Loc.getWindowLocation-    proto    <- Loc.getProtocol loc-    hostname <- Loc.getHostname loc--    let url = case proto of-            "http:"  -> "ws://" <> hostname <> ":9160/gameserver"-            "https:" -> "wss://" <> hostname <> "/gameserver"--    return url--connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket-connectToGameServer handleServerMessage = do-    let handleWSRequest m = do-        maybeSM <- decodeServerMessage m-        case maybeSM of-            Nothing -> return ()-            Just sm -> handleServerMessage sm--    wsURL <- getWebSocketURL-    let req = WS.WebSocketRequest-            { url = wsURL-            , protocols = []-            , onClose = Just $ \_ -> handleServerMessage GameAborted-            , onMessage = Just handleWSRequest-            }-    WS.connect req-  where-    decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)-    decodeServerMessage m = case WS.getData m of-        WS.StringData str -> do-            return $ readMaybe (Data.JSString.unpack str)-        _ -> return Nothing--    encodeClientMessage :: ClientMessage -> JSString-    encodeClientMessage m = Data.JSString.pack (show m)--sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()-sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws-  where-    encodeClientMessage :: ClientMessage -> JSString-    encodeClientMessage m = Data.JSString.pack (show m)--initialGameState :: GameState s-initialGameState = Main CUI.initial--runGame :: GameToken-        -> Int-        -> (StdGen -> s)-        -> (Double -> s -> s)-        -> (Int -> Event -> s -> s)-        -> (Int -> s -> Picture)-        -> IO ()-runGame token numPlayers initial stepHandler eventHandler drawHandler = do-    Just window <- currentWindow-    Just doc <- currentDocument-    Just canvas <- getElementById doc ("screen" :: JSString)-    offscreenCanvas <- Canvas.create 500 500--    setCanvasSize canvas canvas-    setCanvasSize (elementFromCanvas offscreenCanvas) canvas-    on window resize $ do-        liftIO $ setCanvasSize canvas canvas-        liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas--    currentGameState <- newMVar initialGameState--    onEvents canvas $ gameHandle numPlayers initial stepHandler eventHandler token currentGameState--    screen <- js_getCodeWorldContext (canvasFromElement canvas)--    let go t0 lastFrame = do-            gs  <- readMVar currentGameState-            let pic = gameDraw stepHandler drawHandler gs t0-            picFrame <- makeStableName $! pic-            when (picFrame /= lastFrame) $ do-                rect <- getBoundingClientRect canvas-                buffer <- setupScreenContext (elementFromCanvas offscreenCanvas)-                                             rect-                drawFrame buffer pic-                Canvas.restore buffer--                rect <- getBoundingClientRect canvas-                cw <- ClientRect.getWidth rect-                ch <- ClientRect.getHeight rect-                js_canvasDrawImage screen (elementFromCanvas offscreenCanvas)-                                   0 0 (round cw) (round ch)--            t1 <- nextFrame-            modifyMVar_ currentGameState $ return . gameStep stepHandler t1-            go t1 picFrame--    t0 <- getTime-    nullFrame <- makeStableName undefined-    initialStateName <- makeStableName $! initialGameState-    go t0 nullFrame--run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()-run initial stepHandler eventHandler drawHandler = do-    Just window <- currentWindow-    Just doc <- currentDocument-    Just canvas <- getElementById doc ("screen" :: JSString)-    offscreenCanvas <- Canvas.create 500 500--    setCanvasSize canvas canvas-    setCanvasSize (elementFromCanvas offscreenCanvas) canvas-    on window resize $ do-        liftIO $ setCanvasSize canvas canvas-        liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas--    currentState <- newMVar initial-    eventHappened <- newMVar ()--    onEvents canvas $ \event -> do-        changed <- modifyMVarIfNeeded currentState (return . eventHandler event)-        when changed $ void $ tryPutMVar eventHappened ()--    screen <- js_getCodeWorldContext (canvasFromElement canvas)--    let go t0 lastFrame lastStateName needsTime = do-            pic <- drawHandler <$> readMVar currentState-            picFrame <- makeStableName $! pic-            when (picFrame /= lastFrame) $ do-                rect <- getBoundingClientRect canvas-                buffer <- setupScreenContext (elementFromCanvas offscreenCanvas)-                                             rect-                drawFrame buffer pic-                Canvas.restore buffer--                rect <- getBoundingClientRect canvas-                cw <- ClientRect.getWidth rect-                ch <- ClientRect.getHeight rect-                js_canvasDrawImage screen (elementFromCanvas offscreenCanvas)-                                   0 0 (round cw) (round ch)--            t1 <- if-              | needsTime -> do-                  t1 <- nextFrame-                  let dt = min (t1 - t0) 0.25-                  modifyMVar_ currentState (return . stepHandler dt)-                  return t1-              | otherwise -> do-                  takeMVar eventHappened-                  getTime--            nextState <- readMVar currentState-            nextStateName <- makeStableName $! nextState-            nextNeedsTime <- if-                | nextStateName /= lastStateName -> return True-                | not needsTime -> return False-                | otherwise     -> not <$> isUniversallyConstant stepHandler nextState--            go t1 picFrame nextStateName nextNeedsTime--    t0 <- getTime-    nullFrame <- makeStableName undefined-    initialStateName <- makeStableName $! initial-    go t0 nullFrame initialStateName True------------------------------------------------------------------------------------- Stand-Alone event handling and core interaction code--#else--fromButtonNum :: Int -> Maybe MouseButton-fromButtonNum 1 = Just LeftButton-fromButtonNum 2 = Just MiddleButton-fromButtonNum 3 = Just RightButton-fromButtonNum _ = Nothing--getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double)-getMousePos (w,h) (x,y) = ((x - fromIntegral w / 2)/s, -(y - fromIntegral h / 2)/s)-  where-   s = min (realToFrac w / 20) (realToFrac h / 20)--toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event-toEvent rect Canvas.Event {..}-    | eType == "keydown"-    , Just code <- eWhich-    = Just $ KeyPress (keyCodeToText (fromIntegral code))-    | eType == "keyup"-    , Just code <- eWhich-    = Just $ KeyRelease (keyCodeToText (fromIntegral code))-    | eType == "mousedown"-    , Just button <- eWhich >>= fromButtonNum-    , Just pos <- getMousePos rect <$> ePageXY-    = Just $ MousePress button pos-    | eType == "mouseup"-    , Just button <- eWhich >>= fromButtonNum-    , Just pos <- getMousePos rect <$> ePageXY-    = Just $ MouseRelease button pos-    | eType == "mousemove"-    , Just pos <- getMousePos rect <$> ePageXY-    = Just $ MouseMovement pos-    | otherwise-    = Nothing--onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()-onEvents context rect handler = void $ forkIO $ forever $ do-    maybeEvent <- toEvent rect <$> Canvas.wait context-    case maybeEvent of-        Nothing -> return ()-        Just event -> handler event--run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()-run initial stepHandler eventHandler drawHandler = runBlankCanvas $ \context -> do-    let rect = (Canvas.width context, Canvas.height context)-    offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect--    currentState <- newMVar initial-    eventHappened <- newMVar ()--    onEvents context rect $ \event -> do-        modifyMVar_ currentState (return . eventHandler event)-        tryPutMVar eventHappened ()-        return ()--    let go t0 lastFrame lastStateName needsTime = do-            pic <- drawHandler <$> readMVar currentState-            picFrame <- makeStableName $! pic-            when (picFrame /= lastFrame) $ do-                Canvas.send context $ do-                    Canvas.with offscreenCanvas $-                        Canvas.saveRestore $ do-                            setupScreenContext rect-                            drawPicture initialDS pic-                    Canvas.drawImageAt (offscreenCanvas, 0, 0)--            t1 <- if-              | needsTime -> do-                  tn <- getCurrentTime-                  threadDelay $ max 0 (50000 - (round ((tn `diffUTCTime` t0) * 1000000)))-                  t1 <- getCurrentTime-                  let dt = realToFrac (t1 `diffUTCTime` t0)-                  modifyMVar_ currentState (return . stepHandler dt)-                  return t1-              | otherwise -> do-                  takeMVar eventHappened-                  getCurrentTime--            nextState <- readMVar currentState-            nextStateName <- makeStableName $! nextState-            nextNeedsTime <- if nextStateName == lastStateName-                then not <$> isUniversallyConstant stepHandler nextState-                else return True--            go t1 picFrame nextStateName nextNeedsTime--    t0 <- getCurrentTime-    nullFrame <- makeStableName undefined-    initialStateName <- makeStableName $! initial-    go t0 nullFrame initialStateName True--getDeployHash :: IO Text-getDeployHash = error "game API unimplemented in stand-alone interface mode"--runGame :: GameToken-        -> Int-        -> (StdGen -> s)-        -> (Double -> s -> s)-        -> (Int -> Event -> s -> s)-        -> (Int -> s -> Picture)-        -> IO ()-runGame = error "game API unimplemented in stand-alone interface mode"-#endif-------------------------------------------------------------------------------------- Common code for game interface--unsafeCollaborationOf numPlayers initial step event draw = do-    dhash <- getDeployHash-    let token = PartialToken dhash-    runGame token numPlayers initial step event draw `catch` reportError-  where token = NoToken--collaborationOf numPlayers initial step event draw = do-    dhash <- getDeployHash-    let token = FullToken {-                    tokenDeployHash = dhash,-                    tokenNumPlayers = numPlayers,-                    tokenInitial = staticKey initial,-                    tokenStep = staticKey step,-                    tokenEvent = staticKey event,-                    tokenDraw = staticKey draw-                }-    runGame token numPlayers (deRefStaticPtr initial) (deRefStaticPtr step)-            (deRefStaticPtr event) (deRefStaticPtr draw)------------------------------------------------------------------------------------- Common code for interaction, animation and simulation interfaces--interactionOf initial step event draw =-    run initial step event draw `catch` reportError--data Wrapped a = Wrapped {-    state          :: a,-    paused         :: Bool,-    mouseMovedTime :: Double-    } deriving Show--data Control :: * -> * where-  PlayButton    :: Control a-  PauseButton   :: Control a-  StepButton    :: Control a-  RestartButton :: Control Double-  BackButton    :: Control Double-  TimeLabel     :: Control Double--wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a-wrappedStep f dt w = w {-    state          = if paused w then state w else f dt (state w),-    mouseMovedTime = mouseMovedTime w + dt-    }--wrappedEvent :: (Wrapped a -> [Control a])-      -> (Double -> a -> a)-      -> Event -> Wrapped a -> Wrapped a-wrappedEvent _     _ (MouseMovement _)         w-    = w { mouseMovedTime = 0 }-wrappedEvent ctrls f (MousePress LeftButton p) w-    = (foldr (handleControl f p) w (ctrls w)) { mouseMovedTime = 0 }-wrappedEvent _     _ _                         w = w--handleControl :: (Double -> a -> a)-              -> Point-              -> Control a-              -> Wrapped a-              -> Wrapped a-handleControl _ (x,y) RestartButton w-  | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6-      = w { state = 0 }-handleControl _ (x,y) PlayButton    w-  | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6-      = w { paused = False }-handleControl _ (x,y) PauseButton   w-  | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6-      = w { paused = True }-handleControl _ (x,y) BackButton    w-  | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6-      = w { state = max 0 (state w - 0.1) }-handleControl f (x,y) StepButton    w-  | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6-      = w { state = f 0.1 (state w) }-handleControl _ _     _             w = w--wrappedDraw :: (Wrapped a -> [Control a])-     -> (a -> Picture)-     -> Wrapped a -> Picture-wrappedDraw ctrls f w = drawControlPanel ctrls w <> f (state w)--drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture-drawControlPanel ctrls w-  | alpha > 0 = pictures [ drawControl w alpha c | c <- ctrls w ]-  | otherwise = blank-  where alpha | mouseMovedTime w < 4.5  = 1-              | mouseMovedTime w < 5.0  = 10 - 2 * mouseMovedTime w-              | otherwise               = 0--drawControl :: Wrapped a -> Double -> Control a -> Picture-drawControl _ alpha RestartButton = translated (-9) (-9) p-  where p = colored (RGBA 0   0   0   alpha)-                    (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>-                     translated 0.173 (-0.1) (solidRectangle 0.17 0.17))-         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)-         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)--drawControl _ alpha PlayButton = translated (-8) (-9) p-  where p = colored (RGBA 0   0   0   alpha)-                    (solidPolygon [ (-0.2, 0.25), (-0.2, -0.25), (0.2, 0) ])-         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)-         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)--drawControl _ alpha PauseButton = translated (-8) (-9) p-  where p = colored (RGBA 0   0   0   alpha)-                    (translated (-0.15) 0 (solidRectangle 0.2 0.6) <>-                     translated ( 0.15) 0 (solidRectangle 0.2 0.6))-         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)-         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)--drawControl _ alpha BackButton = translated (-7) (-9) p-  where p = colored (RGBA 0   0   0   alpha)-                    (translated 0.15 0 (solidRectangle 0.2 0.5) <>-                     solidPolygon [ (-0.05, 0.25), (-0.05, -0.25), (-0.3, 0) ])-         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)-         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)--drawControl _ alpha StepButton = translated (-6) (-9) p-  where p = colored (RGBA 0   0   0   alpha)-                    (translated (-0.15) 0 (solidRectangle 0.2 0.5) <>-                     solidPolygon [ (0.05, 0.25), (0.05, -0.25), (0.3, 0) ])-         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      0.8 0.8)-         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)--drawControl w alpha TimeLabel = translated (8) (-9) p-  where p = colored (RGBA 0   0   0   alpha)-                    (scaled 0.5 0.5 $-                        text (pack (showFFloatAlt (Just 4) (state w) "s")))-         <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle      3.0 0.8)-         <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)--animationControls :: Wrapped Double -> [Control Double]-animationControls w-  | mouseMovedTime w > 5    = []-  | paused w && state w > 0 = [ RestartButton, PlayButton, StepButton,-                                BackButton, TimeLabel ]-  | paused w                = [ RestartButton, PlayButton, StepButton,-                                TimeLabel ]-  | otherwise               = [ RestartButton, PauseButton, TimeLabel ]--animationOf f =-    interactionOf initial-                  (wrappedStep (+))-                  (wrappedEvent animationControls (+))-                  (wrappedDraw animationControls f)-  where initial = Wrapped {-            state          = 0,-            paused         = False,-            mouseMovedTime = 1000-        }--simulationControls :: Wrapped w -> [Control w]-simulationControls w-  | mouseMovedTime w > 5 = []-  | paused w             = [ PlayButton, StepButton ]-  | otherwise            = [ PauseButton ]--simulationOf simInitial simStep simDraw =-    interactionOf initial-                  (wrappedStep simStep)-                  (wrappedEvent simulationControls simStep)-                  (wrappedDraw simulationControls simDraw)-  where initial = Wrapped {-            state          = simInitial,-            paused         = False,-            mouseMovedTime = 1000-        }---#ifdef ghcjs_HOST_OS------------------------------------------------------------------------------------- GHCJS implementation of tracing and error handling--foreign import javascript unsafe "window.reportRuntimeError($1, $2);"-    js_reportRuntimeError :: Bool -> JSString -> IO ()--trace msg x = unsafePerformIO $ do-    js_reportRuntimeError False (textToJSString msg)-    return x--reportError :: SomeException -> IO ()-reportError e = js_reportRuntimeError True (textToJSString (pack (show e)))--foreign import javascript "/[&?]dhash=(.{22})/.exec(window.location.search)[1]"-    js_deployHash :: IO JSVal--getDeployHash :: IO Text-getDeployHash = pFromJSVal <$> js_deployHash-------------------------------------------------------------------------------------- Stand-alone implementation of tracing and error handling-#else--trace = Debug.Trace.trace . T.unpack--reportError :: SomeException -> IO ()-reportError e = hPrint stderr e-+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}++{-+  Copyright 2018 The CodeWorld Authors. All rights reserved.++  Licensed under the Apache License, Version 2.0 (the "License");+  you may not use this file except in compliance with the License.+  You may obtain a copy of the License at++      http://www.apache.org/licenses/LICENSE-2.0++  Unless required by applicable law or agreed to in writing, software+  distributed under the License is distributed on an "AS IS" BASIS,+  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+  See the License for the specific language governing permissions and+  limitations under the License.+-}+module CodeWorld.Driver+    ( drawingOf+    , animationOf+    , simulationOf+    , interactionOf+    , collaborationOf+    , unsafeCollaborationOf+    , trace+    ) where++import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)+import qualified CodeWorld.CollaborationUI as CUI+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)+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.Stack+import GHC.StaticPtr+import Numeric+import System.Environment+import System.IO+import System.IO.Unsafe+import System.Mem.StableName+import System.Random+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.DOM+import qualified GHCJS.DOM.ClientRect as ClientRect+import GHCJS.DOM.Document+import GHCJS.DOM.Element+import GHCJS.DOM.EventM+import GHCJS.DOM.GlobalEventHandlers+import GHCJS.DOM.MouseEvent+import GHCJS.DOM.NonElementParentNode+import GHCJS.DOM.Types (Element, unElement)+import 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 ()++-- | 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 ()++-- | 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 ()++-- | 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]++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 (Polygon _ pts s) = Shape $ polygonDrawer pts s+pictureToDrawing (Path _ pts w c s) = Shape $ pathDrawer pts w c s+pictureToDrawing (Sector _ b e r) = Shape $ sectorDrawer b e r+pictureToDrawing (Arc _ b e r w) = Shape $ arcDrawer b e r w+pictureToDrawing (Text _ 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 (Rotate _ r p) =+    Transformation (rotateDS r) $ pictureToDrawing p+pictureToDrawing (Pictures 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 _ (a, b, c, d, e, f, Just col) = (a, b, c, d, e, f, Just col)++getColorDS :: DrawState -> Maybe Color+getColorDS (a, b, c, d, e, f, col) = col++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 (text (pack (show k))))+            | k <- [-9,-8 .. 9]+            , k /= 0+            ]+    ynumbers =+        pictures+            [ translated+                0.3+                (fromIntegral k)+                (scaled 0.5 0.5 (text (pack (show k))))+            | k <- [-9,-8 .. 9]+            , k /= 0+            ]+--------------------------------------------------------------------------------+-- GHCJS implementation of drawing+#ifdef ghcjs_HOST_OS+foreign import javascript unsafe+               "$1.drawImage($2, $3, $4, $5, $6);" js_canvasDrawImage ::+               Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()++foreign import javascript unsafe+               "$1.getContext('2d', { alpha: false })" js_getCodeWorldContext ::+               Canvas.Canvas -> IO Canvas.Context++foreign import javascript unsafe "performance.now()"+               js_getHighResTimestamp :: IO Double++canvasFromElement :: Element -> Canvas.Canvas+canvasFromElement = Canvas.Canvas . unElement++elementFromCanvas :: Canvas.Canvas -> Element+elementFromCanvas = pFromJSVal . jsval++getTime :: IO Double+getTime = (/ 1000) <$> js_getHighResTimestamp++nextFrame :: IO Double+nextFrame = waitForAnimationFrame >> getTime++withDS :: Canvas.Context -> DrawState -> IO () -> IO ()+withDS ctx (ta, tb, tc, td, te, tf, col) action = do+    Canvas.save ctx+    Canvas.transform ta tb tc td te tf ctx+    Canvas.beginPath ctx+    action+    Canvas.restore ctx++applyColor :: Canvas.Context -> DrawState -> IO ()+applyColor ctx ds =+    case getColorDS ds of+        Nothing -> do+            Canvas.strokeStyle 0 0 0 1 ctx+            Canvas.fillStyle 0 0 0 1 ctx+        Just (RGBA r g b a) -> do+            Canvas.strokeStyle+                (round $ r * 255)+                (round $ g * 255)+                (round $ b * 255)+                a+                ctx+            Canvas.fillStyle+                (round $ r * 255)+                (round $ g * 255)+                (round $ b * 255)+                a+                ctx++foreign import javascript unsafe "$1.globalCompositeOperation = $2"+               js_setGlobalCompositeOperation ::+               Canvas.Context -> JSString -> IO ()++drawCodeWorldLogo ::+       Canvas.Context -> DrawState -> Int -> Int -> Int -> Int -> IO ()+drawCodeWorldLogo ctx ds x y w h = do+    Just doc <- currentDocument+    Just canvas <- getElementById doc ("cwlogo" :: JSString)+    case getColorDS ds of+        Nothing -> js_canvasDrawImage ctx canvas x y w h+        Just (RGBA r g b a)+            -- This is a tough case.  The best we can do is to allocate an+            -- offscreen buffer as a temporary.+         -> do+            buf <- Canvas.create w h+            bufctx <- js_getCodeWorldContext buf+            applyColor bufctx ds+            Canvas.fillRect 0 0 (fromIntegral w) (fromIntegral h) bufctx+            js_setGlobalCompositeOperation bufctx "destination-in"+            js_canvasDrawImage bufctx canvas 0 0 w h+            js_canvasDrawImage ctx (elementFromCanvas buf) x y w h++-- Debug Mode logic+inspectStatic :: Picture -> IO ()+inspectStatic pic = inspect (return pic) (\_ -> return ()) (\_ _ -> return ())++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++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 <- js_getCodeWorldContext (canvasFromElement canvas)+            rect <- getBoundingClientRect canvas+            buffer <-+                setupScreenContext (elementFromCanvas offscreenCanvas) rect+            drawFrame buffer (node <> coordinatePlaneDrawing)+            Canvas.restore buffer+            rect <- getBoundingClientRect canvas+            cw <- ClientRect.getWidth rect+            ch <- ClientRect.getHeight rect+            js_canvasDrawImage+                screen+                (elementFromCanvas offscreenCanvas)+                0+                0+                (round cw)+                (round ch)+    js_initDebugMode getnodeCB setactiveCB getpictureCB highlightCB drawCB++picToObj :: Picture -> IO JSVal+picToObj = fmap fst . flip State.runStateT 0 . picToObj'++picToObj' :: Picture -> State.StateT Int IO JSVal+picToObj' pic =+    case pic of+        Polygon cs pts smooth -> do+            obj <- init "polygon"+            ptsJS <- pointsToArr pts+            setProps [("points", ptsJS), ("smooth", pToJSVal smooth)] obj+            retVal obj+        Path cs pts w closed smooth -> do+            obj <- init "path"+            ptsJS <- pointsToArr pts+            setProps+                [ ("points", ptsJS)+                , ("width", pToJSVal w)+                , ("closed", pToJSVal closed)+                , ("smooth", pToJSVal smooth)+                ]+                obj+            retVal obj+        Sector cs b e r -> do+            obj <- init "sector"+            setProps+                [ ("startAngle", pToJSVal b)+                , ("endAngle", pToJSVal e)+                , ("radius", pToJSVal r)+                ]+                obj+            retVal obj+        Arc cs b e r w -> do+            obj <- init "arc"+            setProps+                [ ("startAngle", pToJSVal b)+                , ("endAngle", pToJSVal e)+                , ("radius", pToJSVal r)+                , ("width", pToJSVal w)+                ]+                obj+            retVal obj+        Text cs style font txt -> do+            obj <- init "text"+            setProps+                [ ("font", pToJSVal $ fontString style font)+                , ("text", pToJSVal txt)+                ]+                obj+            retVal obj+        Color cs (RGBA r g b a) p -> do+            obj <- init "color"+            picJS <- picToObj' p+            setProps+                [ ("picture", picJS)+                , ("red", pToJSVal r)+                , ("green", pToJSVal g)+                , ("blue", pToJSVal b)+                , ("alpha", pToJSVal a)+                ]+                obj+            retVal obj+        Translate cs x y p -> do+            obj <- init "translate"+            picJS <- picToObj' p+            setProps+                [("picture", picJS), ("x", pToJSVal x), ("y", pToJSVal y)]+                obj+            retVal obj+        Scale cs x y p -> do+            obj <- init "scale"+            picJS <- picToObj' p+            setProps+                [("picture", picJS), ("x", pToJSVal x), ("y", pToJSVal y)]+                obj+            retVal obj+        Rotate cs angle p -> do+            obj <- init "rotate"+            picJS <- picToObj' p+            setProps [("picture", picJS), ("angle", pToJSVal angle)] obj+            retVal obj+        Pictures ps -> do+            obj <- init "pictures"+            arr <- liftIO $ Array.create+            let push = liftIO . flip Array.push arr+            mapM (\p -> picToObj' p >>= push) ps+            setProps [("pictures", unsafeCoerce arr)] obj+            retVal obj+        Logo cs -> init "logo" >>= retVal+        CoordinatePlane cs -> init "coordinatePlane" >>= retVal+  where+    incId :: State.StateT Int IO Int+    incId = do+        currentId <- State.get+        State.put (currentId + 1)+        return currentId+    init :: JSString -> State.StateT Int IO Object+    init tp = do+        obj <- liftIO create+        liftIO $ setProp "type" (pToJSVal tp) obj+        id <- incId+        liftIO $ setProp "id" (pToJSVal id) obj+        liftIO $ setCallInfo pic obj+        return obj+    objToJSVal = unsafeCoerce :: Object -> JSVal+    retVal :: Object -> State.StateT Int IO JSVal+    retVal = return . objToJSVal+    pointsToArr :: [Point] -> State.StateT Int IO JSVal+    pointsToArr pts =+        liftIO $ do+            let go [] _ = return ()+                go ((x, y):pts) arr = do+                    Array.push (pToJSVal x) arr+                    Array.push (pToJSVal y) arr+                    go pts arr+            arr <- Array.create+            go pts arr+            return $ (unsafeCoerce arr :: JSVal)+    setProps xs obj = liftIO $ void $ mapM (\(s, v) -> setProp s v obj) xs++setCallInfo :: Picture -> Object -> IO ()+setCallInfo pic obj =+    case findCSMain (getPictureCS pic) of+        Just (callName, src) -> do+            setProp "name" (pToJSVal $ callName) obj+            setProp "startLine" (pToJSVal $ srcLocStartLine src) obj+            setProp "startCol" (pToJSVal $ srcLocStartCol src) obj+            setProp "endLine" (pToJSVal $ srcLocEndLine src) obj+            setProp "endCol" (pToJSVal $ srcLocEndCol src) obj+        Nothing -> return ()++findCSMain :: CallStack -> Maybe (String, SrcLoc)+findCSMain cs =+    Data.List.find ((== "main") . srcLocPackage . snd) (getCallStack cs)++getPictureCS :: Picture -> CallStack+getPictureCS (Polygon cs _ _) = cs+getPictureCS (Path cs _ _ _ _) = cs+getPictureCS (Sector cs _ _ _) = cs+getPictureCS (Arc cs _ _ _ _) = cs+getPictureCS (Text cs _ _ _) = cs+getPictureCS (Color cs _ _) = cs+getPictureCS (Translate cs _ _ _) = cs+getPictureCS (Scale cs _ _ _) = cs+getPictureCS (Rotate cs _ _) = cs+getPictureCS (Logo cs) = cs+getPictureCS (CoordinatePlane cs) = cs+getPictureCS (Pictures _) = emptyCallStack++-- 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+    offscreen <- Canvas.create 500 500+    context <- Canvas.getContext offscreen+    (found, node) <-+        findTopShape+            context+            (translateDS (10 - x / 25) (y / 25 - 10) initialDS)+            pic+    case found of+        True -> return $ Just node+        False -> return Nothing++findTopShape :: Canvas.Context -> DrawState -> Drawing -> IO (Bool, Int)+findTopShape ctx ds (Shape drawer) = do+    contained <- shapeContains $ drawer ctx ds+    case contained of+        True -> return (True, 0)+        False -> return (False, 1)+findTopShape ctx ds (Transformation f d) =+    map2 (+ 1) $ findTopShape ctx (f ds) d+findTopShape ctx ds (Drawings []) = return (False, 1)+findTopShape ctx ds (Drawings (dr:drs)) = do+    (found, count) <- findTopShape ctx ds dr+    case found of+        True -> return (True, count + 1)+        False -> map2 (+ count) $ findTopShape ctx ds (Drawings drs)++map2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+map2 = fmap . fmap++isPointInPath :: Canvas.Context -> IO Bool+isPointInPath = js_isPointInPath 0 0++isPointInStroke :: Canvas.Context -> IO Bool+isPointInStroke = js_isPointInStroke 0 0++-- Canvas.isPointInPath does not provide a way to get the return value+-- https://github.com/ghcjs/ghcjs-base/blob/master/JavaScript/Web/Canvas.hs#L212+foreign import javascript unsafe "$3.isPointInPath($1,$2)"+               js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool++foreign import javascript unsafe "$3.isPointInStroke($1,$2)"+               js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool++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 ()++-----------------------------------------------------------------------------------+-- GHCJS Drawing+type Drawer = Canvas.Context -> DrawState -> DrawMethods++data DrawMethods = DrawMethods+    { drawShape :: IO ()+    , shapeContains :: IO Bool+    }++polygonDrawer ps smooth ctx ds =+    DrawMethods+    { drawShape = trace >> applyColor ctx ds >> Canvas.fill ctx+    , shapeContains = trace >> isPointInPath ctx+    }+  where+    trace = withDS ctx ds $ followPath ctx ps True smooth++pathDrawer ps w closed smooth ctx ds =+    DrawMethods+    { drawShape = drawFigure ctx ds w $ followPath ctx ps closed smooth+    , shapeContains =+          do let width =+                     if w == 0+                         then 0.3+                         else w+             drawFigure ctx ds width $ followPath ctx ps closed smooth+             isPointInStroke ctx+    }++sectorDrawer b e r ctx ds =+    DrawMethods+    { drawShape = trace >> applyColor ctx ds >> Canvas.fill ctx+    , shapeContains = trace >> isPointInPath ctx+    }+  where+    trace =+        withDS ctx ds $ do+            Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx+            Canvas.lineTo 0 0 ctx++arcDrawer b e r w ctx ds =+    DrawMethods+    { drawShape =+          drawFigure ctx ds w $ Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx+    , shapeContains =+          do let width =+                     if w == 0+                         then 0.3+                         else w+             Canvas.lineWidth (width * 25) ctx+             drawFigure ctx ds width $+                 Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx+             isPointInStroke ctx+    }++textDrawer sty fnt txt ctx ds =+    DrawMethods+    { drawShape =+          withDS ctx ds $ do+              Canvas.scale 1 (-1) ctx+              applyColor ctx ds+              Canvas.font (fontString sty fnt) ctx+              Canvas.fillText (textToJSString txt) 0 0 ctx+    , shapeContains =+          do Canvas.font (fontString sty fnt) ctx+             width <- Canvas.measureText (textToJSString txt) ctx+             let height = 25 -- constant, defined in fontString+             withDS ctx ds $+                 Canvas.rect ((-0.5) * width) ((-0.5) * height) width height ctx+             isPointInPath ctx+    }++logoDrawer ctx ds =+    DrawMethods+    { drawShape =+          withDS ctx ds $ do+              Canvas.scale 1 (-1) ctx+              drawCodeWorldLogo ctx ds (-225) (-50) 450 100+    , shapeContains =+          do withDS ctx ds $ Canvas.rect (-225) (-50) 450 100 ctx+             isPointInPath ctx+    }++coordinatePlaneDrawer ctx ds =+    DrawMethods+    { drawShape = drawDrawing ctx ds coordinatePlaneDrawing+    , shapeContains = fst <$> findTopShape ctx ds coordinatePlaneDrawing+    }++foreign import javascript unsafe "showCanvas()" js_showCanvas ::+               IO ()++followPath :: Canvas.Context -> [Point] -> Bool -> Bool -> IO ()+followPath ctx [] closed _ = return ()+followPath ctx [p1] closed _ = return ()+followPath ctx ((sx, sy):ps) closed False = do+    Canvas.moveTo (25 * sx) (25 * sy) ctx+    forM_ ps $ \(x, y) -> Canvas.lineTo (25 * x) (25 * y) ctx+    when closed $ Canvas.closePath ctx+followPath ctx [p1, p2] False True = followPath ctx [p1, p2] False False+followPath ctx ps False True = do+    let [(x1, y1), (x2, y2), (x3, y3)] = take 3 ps+        dprev = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+        dnext = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+        p = dprev / (dprev + dnext)+        cx = x2 + p * (x1 - x3) / 2+        cy = y2 + p * (y1 - y3) / 2+    Canvas.moveTo (25 * x1) (25 * y1) ctx+    Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x2) (25 * y2) ctx+    forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) ->+        let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+            d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+            d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)+            p = d1 / (d1 + d2)+            r = d1 / (dp + d1)+            cx1 = x2 + r * (x3 - x1) / 2+            cy1 = y2 + r * (y3 - y1) / 2+            cx2 = x3 + p * (x2 - x4) / 2+            cy2 = y3 + p * (y2 - y4) / 2+        in Canvas.bezierCurveTo+               (25 * cx1)+               (25 * cy1)+               (25 * cx2)+               (25 * cy2)+               (25 * x3)+               (25 * y3)+               ctx+    let [(x1, y1), (x2, y2), (x3, y3)] = reverse $ take 3 $ reverse ps+        dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+        d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+        r = d1 / (dp + d1)+        cx = x2 + r * (x3 - x1) / 2+        cy = y2 + r * (y3 - y1) / 2+    Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x3) (25 * y3) ctx+followPath ctx ps@(_:(sx, sy):_) True True = do+    Canvas.moveTo (25 * sx) (25 * sy) ctx+    let rep = cycle ps+    forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) ->+        let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+            d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+            d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)+            p = d1 / (d1 + d2)+            r = d1 / (dp + d1)+            cx1 = x2 + r * (x3 - x1) / 2+            cy1 = y2 + r * (y3 - y1) / 2+            cx2 = x3 + p * (x2 - x4) / 2+            cy2 = y3 + p * (y2 - y4) / 2+        in Canvas.bezierCurveTo+               (25 * cx1)+               (25 * cy1)+               (25 * cx2)+               (25 * cy2)+               (25 * x3)+               (25 * y3)+               ctx+    Canvas.closePath ctx++drawFigure :: Canvas.Context -> DrawState -> Double -> IO () -> IO ()+drawFigure ctx ds w figure = do+    withDS ctx ds $ do+        figure+        when (w /= 0) $ do+            Canvas.lineWidth (25 * w) ctx+            applyColor ctx ds+            Canvas.stroke ctx+    when (w == 0) $ do+        Canvas.lineWidth 1 ctx+        applyColor ctx ds+        Canvas.stroke ctx++fontString :: TextStyle -> Font -> JSString+fontString style font = stylePrefix style <> "25px " <> fontName font+  where+    stylePrefix Plain = ""+    stylePrefix Bold = "bold "+    stylePrefix Italic = "italic "+    fontName SansSerif = "sans-serif"+    fontName Serif = "serif"+    fontName Monospace = "monospace"+    fontName Handwriting = "cursive"+    fontName Fancy = "fantasy"+    fontName (NamedFont txt) =+        "\"" <> textToJSString (T.filter (/= '"') txt) <> "\""++drawDrawing :: Canvas.Context -> DrawState -> Drawing -> IO ()+drawDrawing ctx ds (Shape shape) = drawShape $ shape ctx ds+drawDrawing ctx ds (Transformation f d) = drawDrawing ctx (f ds) d+drawDrawing ctx ds (Drawings drs) = mapM_ (drawDrawing ctx ds) (reverse drs)++drawFrame :: Canvas.Context -> Drawing -> IO ()+drawFrame ctx drawing = do+    Canvas.fillStyle 255 255 255 1 ctx+    Canvas.fillRect (-250) (-250) 500 500 ctx+    drawDrawing ctx initialDS drawing++setupScreenContext :: Element -> ClientRect.ClientRect -> IO Canvas.Context+setupScreenContext canvas rect = do+    cw <- ClientRect.getWidth rect+    ch <- ClientRect.getHeight rect+    ctx <- js_getCodeWorldContext (canvasFromElement canvas)+    Canvas.save ctx+    Canvas.translate (realToFrac cw / 2) (realToFrac ch / 2) ctx+    Canvas.scale (realToFrac cw / 500) (-realToFrac ch / 500) ctx+    Canvas.lineWidth 0 ctx+    Canvas.textAlign Canvas.Center ctx+    Canvas.textBaseline Canvas.Middle ctx+    return ctx++setCanvasSize :: Element -> Element -> IO ()+setCanvasSize target canvas = do+    rect <- getBoundingClientRect canvas+    cx <- ClientRect.getWidth rect+    cy <- ClientRect.getHeight rect+    setAttribute target ("width" :: JSString) (show (round cx))+    setAttribute target ("height" :: JSString) (show (round cy))++drawingOf pic = runStatic pic+--------------------------------------------------------------------------------+-- Stand-alone implementation of drawing+#else+withDS :: DrawState -> Canvas () -> Canvas ()+withDS (ta, tb, tc, td, te, tf, col) action =+    Canvas.saveRestore $ do+        Canvas.transform (ta, tb, tc, td, te, tf)+        Canvas.beginPath ()+        action++applyColor :: DrawState -> Canvas ()+applyColor ds =+    case getColorDS ds of+        Nothing -> do+            Canvas.strokeStyle "black"+            Canvas.fillStyle "black"+        Just (RGBA r g b a) -> do+            let style =+                    pack $+                    printf+                        "rgba(%.0f,%.0f,%.0f,%f)"+                        (r * 255)+                        (g * 255)+                        (b * 255)+                        a+            Canvas.strokeStyle style+            Canvas.fillStyle style++drawFigure :: DrawState -> Double -> Canvas () -> Canvas ()+drawFigure ds w figure = do+    withDS ds $ do+        figure+        when (w /= 0) $ do+            Canvas.lineWidth (25 * w)+            applyColor ds+            Canvas.stroke ()+    when (w == 0) $ do+        Canvas.lineWidth 1+        applyColor ds+        Canvas.stroke ()++followPath :: [Point] -> Bool -> Bool -> Canvas ()+followPath [] closed _ = return ()+followPath [p1] closed _ = return ()+followPath ((sx, sy):ps) closed False = do+    Canvas.moveTo (25 * sx, 25 * sy)+    forM_ ps $ \(x, y) -> Canvas.lineTo (25 * x, 25 * y)+    when closed $ Canvas.closePath ()+followPath [p1, p2] False True = followPath [p1, p2] False False+followPath ps False True = do+    let [(x1, y1), (x2, y2), (x3, y3)] = take 3 ps+        dprev = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+        dnext = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+        p = dprev / (dprev + dnext)+        cx = x2 + p * (x1 - x3) / 2+        cy = y2 + p * (y1 - y3) / 2+    Canvas.moveTo (25 * x1, 25 * y1)+    Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x2, 25 * y2)+    forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) ->+        let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+            d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+            d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)+            p = d1 / (d1 + d2)+            r = d1 / (dp + d1)+            cx1 = x2 + r * (x3 - x1) / 2+            cy1 = y2 + r * (y3 - y1) / 2+            cx2 = x3 + p * (x2 - x4) / 2+            cy2 = y3 + p * (y2 - y4) / 2+        in Canvas.bezierCurveTo+               (25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2, 25 * x3, 25 * y3)+    let [(x1, y1), (x2, y2), (x3, y3)] = reverse $ take 3 $ reverse ps+        dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+        d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+        r = d1 / (dp + d1)+        cx = x2 + r * (x3 - x1) / 2+        cy = y2 + r * (y3 - y1) / 2+    Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x3, 25 * y3)+followPath ps@(_:(sx, sy):_) True True = do+    Canvas.moveTo (25 * sx, 25 * sy)+    let rep = cycle ps+    forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) ->+        let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+            d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+            d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)+            p = d1 / (d1 + d2)+            r = d1 / (dp + d1)+            cx1 = x2 + r * (x3 - x1) / 2+            cy1 = y2 + r * (y3 - y1) / 2+            cx2 = x3 + p * (x2 - x4) / 2+            cy2 = y3 + p * (y2 - y4) / 2+        in Canvas.bezierCurveTo+               (25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2, 25 * x3, 25 * y3)+    Canvas.closePath ()++fontString :: TextStyle -> Font -> Text+fontString style font = stylePrefix style <> "25px " <> fontName font+  where+    stylePrefix Plain = ""+    stylePrefix Bold = "bold "+    stylePrefix Italic = "italic "+    fontName SansSerif = "sans-serif"+    fontName Serif = "serif"+    fontName Monospace = "monospace"+    fontName Handwriting = "cursive"+    fontName Fancy = "fantasy"+    fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\""++type Drawer = DrawState -> Canvas ()++polygonDrawer ps smooth ds = do+    withDS ds $ followPath ps True smooth+    applyColor ds+    Canvas.fill ()++pathDrawer ps w closed smooth ds = drawFigure ds w $ followPath ps closed smooth++sectorDrawer b e r ds =+    withDS ds $ do+        Canvas.arc (0, 0, 25 * abs r, b, e, b > e)+        Canvas.lineTo (0, 0)+        applyColor ds+        Canvas.fill ()++arcDrawer b e r w ds =+    withDS ds $ drawFigure ds w $ Canvas.arc (0, 0, 25 * abs r, b, e, b > e)++textDrawer sty fnt txt ds =+    withDS ds $ do+        Canvas.scale (1, -1)+        applyColor ds+        Canvas.font (fontString sty fnt)+        Canvas.fillText (txt, 0, 0)++logoDrawer ds = return ()++coordinatePlaneDrawer ds = drawDrawing ds coordinatePlaneDrawing++drawDrawing :: DrawState -> Drawing -> Canvas ()+drawDrawing ds (Shape drawer) = drawer ds+drawDrawing ds (Transformation f d) = drawDrawing (f ds) d+drawDrawing ds (Drawings drs) = mapM_ (drawDrawing ds) (reverse drs)++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++display :: Drawing -> IO ()+display drawing =+    runBlankCanvas $ \context ->+        Canvas.send context $+        Canvas.saveRestore $ do+            let rect = (Canvas.width context, Canvas.height context)+            setupScreenContext rect+            drawDrawing initialDS drawing++drawingOf pic = display (pictureToDrawing pic)+#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 -> IO Bool+isUniversallyConstant f old =+    falseOr $ do+        oldName <- makeStableName old+        genName <- makeStableName $! f undefined old+        return (genName == oldName)+  where+    falseOr x = x `catch` \(e :: SomeException) -> return False++applyIfModifying :: (s -> IO s) -> s -> IO (Maybe s)+applyIfModifying f s0 = do+    oldName <- makeStableName $! s0+    s1 <- f s0+    newName <- makeStableName $! s1+    if newName /= oldName+        then return (Just s1)+        else return Nothing++modifyMVarIfNeeded :: MVar s -> (s -> IO s) -> IO Bool+modifyMVarIfNeeded var f =+    modifyMVar var $ \s0 -> do+        ms1 <- applyIfModifying f s0+        case ms1 of+            Nothing -> return (s0, False)+            Just s1 -> return (s1, True)++data GameToken+    = FullToken { tokenDeployHash :: Text+                , tokenNumPlayers :: Int+                , tokenInitial :: StaticKey+                , tokenStep :: StaticKey+                , tokenEvent :: StaticKey+                , tokenDraw :: StaticKey }+    | PartialToken { tokenDeployHash :: Text }+    | NoToken+    deriving (Generic)++deriving instance Generic Fingerprint++instance Serialize Fingerprint++instance Serialize GameToken+--------------------------------------------------------------------------------+-- GHCJS event handling and core interaction code+#ifdef ghcjs_HOST_OS+getMousePos :: IsMouseEvent e => Element -> EventM w e Point+getMousePos canvas = do+    (ix, iy) <- mouseClientXY+    liftIO $ do+        rect <- getBoundingClientRect canvas+        cx <- ClientRect.getLeft rect+        cy <- ClientRect.getTop rect+        cw <- ClientRect.getWidth rect+        ch <- ClientRect.getHeight rect+        return+            ( 20 * fromIntegral (ix - round cx) / realToFrac cw - 10+            , 20 * fromIntegral (round cy - iy) / realToFrac cw + 10)++fromButtonNum :: Word -> Maybe MouseButton+fromButtonNum 0 = Just LeftButton+fromButtonNum 1 = Just MiddleButton+fromButtonNum 2 = Just RightButton+fromButtonNum _ = Nothing++onEvents :: Element -> (Event -> IO ()) -> IO ()+onEvents canvas handler = do+    Just window <- currentWindow+    on window keyDown $ do+        code <- uiKeyCode+        let keyName = keyCodeToText code+        when (keyName /= "") $ do+            liftIO $ handler (KeyPress keyName)+            preventDefault+            stopPropagation+    on window keyUp $ do+        code <- uiKeyCode+        let keyName = keyCodeToText code+        when (keyName /= "") $ do+            liftIO $ handler (KeyRelease keyName)+            preventDefault+            stopPropagation+    on window mouseDown $ do+        button <- mouseButton+        case fromButtonNum button of+            Nothing -> return ()+            Just btn -> do+                pos <- getMousePos canvas+                liftIO $ handler (MousePress btn pos)+    on window mouseUp $ do+        button <- mouseButton+        case fromButtonNum button of+            Nothing -> return ()+            Just btn -> do+                pos <- getMousePos canvas+                liftIO $ handler (MouseRelease btn pos)+    on window mouseMove $ do+        pos <- getMousePos canvas+        liftIO $ handler (MouseMovement pos)+    return ()++encodeEvent :: (Timestamp, Maybe Event) -> String+encodeEvent = show++decodeEvent :: String -> Maybe (Timestamp, Maybe Event)+decodeEvent = readMaybe++data GameState s+    = Main (UIState SMain)+    | Connecting WS.WebSocket+                 (UIState SConnect)+    | Waiting WS.WebSocket+              GameId+              PlayerId+              (UIState SWait)+    | Running WS.WebSocket+              GameId+              Timestamp+              PlayerId+              (Future s)++isRunning :: GameState s -> Bool+isRunning Running {} = True+isRunning _ = False++gameTime :: GameState s -> Timestamp -> Double+gameTime (Running _ _ tstart _ _) t = t - tstart+gameTime _ _ = 0++-- It's worth trying to keep the canonical animation rate exactly representable+-- as a float, to minimize the chance of divergence due to rounding error.+gameRate :: Double+gameRate = 1 / 16++gameStep :: (Double -> s -> s) -> Double -> GameState s -> GameState s+gameStep _ t (Main s) = Main (CUI.step t s)+gameStep _ t (Connecting ws s) = Connecting ws (CUI.step t s)+gameStep _ t (Waiting ws gid pid s) = Waiting ws gid pid (CUI.step t s)+gameStep step t (Running ws gid tstart pid s) =+    Running ws gid tstart pid (currentTimePasses step gameRate (t - tstart) s)++gameDraw ::+       (Double -> s -> s)+    -> (PlayerId -> s -> Picture)+    -> GameState s+    -> Timestamp+    -> Picture+gameDraw _ _ (Main s) _ = CUI.picture s+gameDraw _ _ (Connecting _ s) _ = CUI.picture s+gameDraw _ _ (Waiting _ _ _ s) _ = CUI.picture s+gameDraw step draw (Running _ _ tstart pid s) t =+    draw pid (currentState step gameRate (t - tstart) s)++handleServerMessage ::+       Int+    -> (StdGen -> s)+    -> (Double -> s -> s)+    -> (PlayerId -> Event -> s -> s)+    -> MVar (GameState s)+    -> ServerMessage+    -> IO ()+handleServerMessage numPlayers initial stepHandler eventHandler gsm sm = do+    modifyMVar_ gsm $ \gs -> do+        t <- getTime+        case (sm, gs) of+            (GameAborted, _) -> return initialGameState+            (JoinedAs pid gid, Connecting ws s) ->+                return (Waiting ws gid pid (CUI.startWaiting gid s))+            (PlayersWaiting m n, Waiting ws gid pid s) ->+                return (Waiting ws gid pid (CUI.updatePlayers n m s))+            (Started, Waiting ws gid pid _) ->+                return+                    (Running+                         ws+                         gid+                         t+                         pid+                         (initFuture (initial (mkStdGen (hash gid))) numPlayers))+            (OutEvent pid eo, Running ws gid tstart mypid s) ->+                case decodeEvent eo of+                    Just (t', event) ->+                        let ours = pid == mypid+                            func = eventHandler pid <$> event -- might be a ping (Nothing)+                            result+                                | ours = s -- we already took care of our events+                                | otherwise =+                                    addEvent+                                        stepHandler+                                        gameRate+                                        mypid+                                        t'+                                        func+                                        s+                        in return (Running ws gid tstart mypid result)+                    Nothing -> return (Running ws gid tstart mypid s)+            _ -> return gs+    return ()++gameHandle ::+       Int+    -> (StdGen -> s)+    -> (Double -> s -> s)+    -> (PlayerId -> Event -> s -> s)+    -> GameToken+    -> MVar (GameState s)+    -> Event+    -> IO ()+gameHandle numPlayers initial stepHandler eventHandler token gsm event = do+    gs <- takeMVar gsm+    case gs of+        Main s ->+            case CUI.event event s of+                ContinueMain s' -> do+                    putMVar gsm (Main s')+                Create s' -> do+                    ws <-+                        connectToGameServer+                            (handleServerMessage+                                 numPlayers+                                 initial+                                 stepHandler+                                 eventHandler+                                 gsm)+                    sendClientMessage ws (NewGame numPlayers (encode token))+                    putMVar gsm (Connecting ws s')+                Join gid s' -> do+                    ws <-+                        connectToGameServer+                            (handleServerMessage+                                 numPlayers+                                 initial+                                 stepHandler+                                 eventHandler+                                 gsm)+                    sendClientMessage ws (JoinGame gid (encode token))+                    putMVar gsm (Connecting ws s')+        Connecting ws s ->+            case CUI.event event s of+                ContinueConnect s' -> do+                    putMVar gsm (Connecting ws s')+                CancelConnect s' -> do+                    WS.close Nothing Nothing ws+                    putMVar gsm (Main s')+        Waiting ws gid pid s ->+            case CUI.event event s of+                ContinueWait s' -> do+                    putMVar gsm (Waiting ws gid pid s')+                CancelWait s' -> do+                    WS.close Nothing Nothing ws+                    putMVar gsm (Main s')+        Running ws gid tstart pid f -> do+            t <- getTime+            let gameState0 = currentState stepHandler gameRate (t - tstart) f+            let eventFun = eventHandler pid event+            ms1 <- (return . eventFun) `applyIfModifying` gameState0+            case ms1 of+                Nothing -> do+                    putMVar gsm gs+                Just s1 -> do+                    sendClientMessage+                        ws+                        (InEvent (encodeEvent (gameTime gs t, Just event)))+                    let f1 =+                            addEvent+                                stepHandler+                                gameRate+                                pid+                                (t - tstart)+                                (Just eventFun)+                                f+                    putMVar gsm (Running ws gid tstart pid f1)++getWebSocketURL :: IO JSString+getWebSocketURL = do+    loc <- Loc.getWindowLocation+    proto <- Loc.getProtocol loc+    hostname <- Loc.getHostname loc+    let url =+            case proto of+                "http:" -> "ws://" <> hostname <> ":9160/gameserver"+                "https:" -> "wss://" <> hostname <> "/gameserver"+    return url++connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket+connectToGameServer handleServerMessage = do+    let handleWSRequest m = do+            maybeSM <- decodeServerMessage m+            case maybeSM of+                Nothing -> return ()+                Just sm -> handleServerMessage sm+    wsURL <- getWebSocketURL+    let req =+            WS.WebSocketRequest+            { url = wsURL+            , protocols = []+            , onClose = Just $ \_ -> handleServerMessage GameAborted+            , onMessage = Just handleWSRequest+            }+    WS.connect req+  where+    decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)+    decodeServerMessage m =+        case WS.getData m of+            WS.StringData str -> do+                return $ readMaybe (Data.JSString.unpack str)+            _ -> return Nothing+    encodeClientMessage :: ClientMessage -> JSString+    encodeClientMessage m = Data.JSString.pack (show m)++sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()+sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws+  where+    encodeClientMessage :: ClientMessage -> JSString+    encodeClientMessage m = Data.JSString.pack (show m)++initialGameState :: GameState s+initialGameState = Main CUI.initial++foreign import javascript+               "/[&?]dhash=(.{22})/.exec(window.location.search)[1]" js_deployHash+               :: IO JSVal++getDeployHash :: IO Text+getDeployHash = pFromJSVal <$> js_deployHash++runGame ::+       GameToken+    -> Int+    -> (StdGen -> s)+    -> (Double -> s -> s)+    -> (Int -> Event -> s -> s)+    -> (Int -> s -> Picture)+    -> IO ()+runGame token numPlayers initial stepHandler eventHandler drawHandler = do+    js_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+            stepHandler+            eventHandler+            token+            currentGameState+    screen <- js_getCodeWorldContext (canvasFromElement canvas)+    let go t0 lastFrame = do+            gs <- readMVar currentGameState+            let pic = gameDraw stepHandler drawHandler gs t0+            picFrame <- makeStableName $! pic+            when (picFrame /= lastFrame) $ do+                rect <- getBoundingClientRect canvas+                buffer <-+                    setupScreenContext (elementFromCanvas offscreenCanvas) rect+                drawFrame buffer (pictureToDrawing pic)+                Canvas.restore buffer+                rect <- getBoundingClientRect canvas+                cw <- ClientRect.getWidth rect+                ch <- ClientRect.getHeight rect+                js_canvasDrawImage+                    screen+                    (elementFromCanvas offscreenCanvas)+                    0+                    0+                    (round cw)+                    (round ch)+            t1 <- nextFrame+            modifyMVar_ currentGameState $ return . gameStep stepHandler t1+            go t1 picFrame+    t0 <- getTime+    nullFrame <- makeStableName undefined+    initialStateName <- makeStableName $! initialGameState+    go t0 nullFrame++run :: s+    -> (Double -> s -> s)+    -> (e -> s -> s)+    -> (s -> Drawing)+    -> IO (e -> IO (), IO s)+run initial stepHandler eventHandler drawHandler = do+    js_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+    currentState <- newMVar initial+    eventHappened <- newMVar ()+    let sendEvent event = do+            changed <-+                modifyMVarIfNeeded currentState (return . eventHandler event)+            when changed $ void $ tryPutMVar eventHappened ()+        getState = readMVar currentState+    screen <- js_getCodeWorldContext (canvasFromElement canvas)+    let go t0 lastFrame lastStateName needsTime = do+            pic <- drawHandler <$> readMVar currentState+            picFrame <- makeStableName $! pic+            when (picFrame /= lastFrame) $ do+                rect <- getBoundingClientRect canvas+                buffer <-+                    setupScreenContext (elementFromCanvas offscreenCanvas) rect+                drawFrame buffer pic+                Canvas.restore buffer+                rect <- getBoundingClientRect canvas+                cw <- ClientRect.getWidth rect+                ch <- ClientRect.getHeight rect+                js_canvasDrawImage+                    screen+                    (elementFromCanvas offscreenCanvas)+                    0+                    0+                    (round cw)+                    (round ch)+            t1 <-+                if | needsTime ->+                       do t1 <- nextFrame+                          let dt = min (t1 - t0) 0.25+                          modifyMVar_ currentState (return . stepHandler dt)+                          return t1+                   | otherwise ->+                       do takeMVar eventHappened+                          getTime+            nextState <- readMVar currentState+            nextStateName <- makeStableName $! nextState+            nextNeedsTime <-+                if | nextStateName /= lastStateName -> return True+                   | not needsTime -> return False+                   | otherwise ->+                       not <$> isUniversallyConstant stepHandler nextState+            go t1 picFrame nextStateName nextNeedsTime+    t0 <- getTime+    nullFrame <- makeStableName undefined+    initialStateName <- makeStableName $! initial+    forkIO $ go t0 nullFrame initialStateName True+    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++runStatic :: Picture -> IO ()+runStatic pic = do+    js_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+    screen <- js_getCodeWorldContext (canvasFromElement canvas)+    debugState <- newMVar debugStateInit+    let draw =+            flip drawDebugState (pictureToDrawing pic) <$> readMVar debugState+        drawToScreen = do+            drawing <- draw+            rect <- getBoundingClientRect canvas+            buffer <-+                setupScreenContext (elementFromCanvas offscreenCanvas) rect+            drawFrame buffer drawing+            Canvas.restore buffer+            rect <- getBoundingClientRect canvas+            cw <- ClientRect.getWidth rect+            ch <- ClientRect.getHeight rect+            js_canvasDrawImage+                screen+                (elementFromCanvas offscreenCanvas)+                0+                0+                (round cw)+                (round ch)+        sendEvent evt = do+            takeMVar debugState >>= putMVar debugState . updateDebugState evt+            drawToScreen+        handlePause True = sendEvent DebugStart+        handlePause False = sendEvent DebugStop+        handleHighlight True node = sendEvent $ HighlightEvent node+        handleHighlight False node = sendEvent $ SelectEvent node+    on window resize $+        liftIO $ do+            setCanvasSize canvas canvas+            setCanvasSize (elementFromCanvas offscreenCanvas) canvas+            drawToScreen+    inspect (return pic) handlePause handleHighlight+    drawToScreen++-- Wraps the event and state from run so they can be paused by pressing the Inspect+-- button.+runInspect ::+       s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()+runInspect initial stepHandler eventHandler drawHandler = do+    Just window <- currentWindow+    Just doc <- currentDocument+    Just canvas <- getElementById doc ("screen" :: JSString)+    let initialWrapper = (debugStateInit, initial)+        stepHandlerWrapper dt (debugState, state) =+            case debugStateActive debugState of+                True -> (debugState, state)+                False -> (debugState, stepHandler dt state)+        eventHandlerWrapper evt (debugState, state) =+            case evt of+                Left debugEvent ->+                    (updateDebugState debugEvent debugState, state)+                Right normalEvent ->+                    (debugState, eventHandler normalEvent state)+        drawHandlerWrapper (debugState, state) =+            drawDebugState debugState (pictureToDrawing $ drawHandler state)+        drawPicHandler (debugState, state) = drawHandler state+    (sendEvent, getState) <-+        run+            initialWrapper+            stepHandlerWrapper+            eventHandlerWrapper+            drawHandlerWrapper+    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++runPauseable ::+       Wrapped s+    -> (Double -> s -> s)+    -> (Wrapped s -> [Control s])+    -> (s -> Picture)+    -> IO ()+runPauseable initial stepHandler controls drawHandler = do+    Just window <- currentWindow+    Just doc <- currentDocument+    Just canvas <- getElementById doc ("screen" :: JSString)+    let initialWrapper = (debugStateInit, initial)+        stepHandlerWrapper dt (debugState, wrappedState) =+            case debugStateActive debugState of+                True -> (debugState, wrappedState)+                False -> (debugState, wrappedStep stepHandler dt wrappedState)+        eventHandlerWrapper evt (debugState, wrappedState) =+            case evt of+                Left debugEvent ->+                    (updateDebugState debugEvent debugState, wrappedState)+                Right normalEvent ->+                    ( debugState+                    , wrappedEvent controls stepHandler normalEvent wrappedState)+        drawHandlerWrapper (debugState, wrappedState) =+            case debugStateActive debugState of+                True -> drawDebugState debugState plainDrawing+                False ->+                    pictureToDrawing $+                    wrappedDraw controls drawHandler wrappedState+          where+            plainDrawing = pictureToDrawing $ drawHandler (state wrappedState)+        drawPicHandler (debugState, wrappedState) =+            drawHandler $ state wrappedState+    (sendEvent, getState) <-+        run+            initialWrapper+            stepHandlerWrapper+            eventHandlerWrapper+            drawHandlerWrapper+    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++-- 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+--------------------------------------------------------------------------------+-- Stand-Alone event handling and core interaction code+#else+fromButtonNum :: Int -> Maybe MouseButton+fromButtonNum 1 = Just LeftButton+fromButtonNum 2 = Just MiddleButton+fromButtonNum 3 = Just RightButton+fromButtonNum _ = Nothing++getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double)+getMousePos (w, h) (x, y) =+    ((x - fromIntegral w / 2) / s, -(y - fromIntegral h / 2) / s)+  where+    s = min (realToFrac w / 20) (realToFrac h / 20)++toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event+toEvent rect Canvas.Event {..}+    | eType == "keydown"+    , Just code <- eWhich = Just $ KeyPress (keyCodeToText (fromIntegral code))+    | eType == "keyup"+    , Just code <- eWhich =+        Just $ KeyRelease (keyCodeToText (fromIntegral code))+    | eType == "mousedown"+    , Just button <- eWhich >>= fromButtonNum+    , Just pos <- getMousePos rect <$> ePageXY = Just $ MousePress button pos+    | eType == "mouseup"+    , Just button <- eWhich >>= fromButtonNum+    , Just pos <- getMousePos rect <$> ePageXY = Just $ MouseRelease button pos+    | eType == "mousemove"+    , Just pos <- getMousePos rect <$> ePageXY = Just $ MouseMovement pos+    | otherwise = Nothing++onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()+onEvents context rect handler =+    void $+    forkIO $+    forever $ do+        maybeEvent <- toEvent rect <$> Canvas.wait context+        forM_ maybeEvent handler++run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()+run initial stepHandler eventHandler drawHandler =+    runBlankCanvas $ \context -> do+        let rect = (Canvas.width context, Canvas.height context)+        offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect+        currentState <- newMVar initial+        eventHappened <- newMVar ()+        onEvents context rect $ \event -> do+            modifyMVar_ currentState (return . eventHandler event)+            tryPutMVar eventHappened ()+            return ()+        let go t0 lastFrame lastStateName needsTime = do+                pic <- drawHandler <$> readMVar currentState+                picFrame <- makeStableName $! pic+                when (picFrame /= lastFrame) $+                    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 . stepHandler dt)+                              return t1+                       | otherwise ->+                           do takeMVar eventHappened+                              getCurrentTime+                nextState <- readMVar currentState+                nextStateName <- makeStableName $! nextState+                nextNeedsTime <-+                    if nextStateName == lastStateName+                        then not <$> isUniversallyConstant stepHandler nextState+                        else return True+                go t1 picFrame nextStateName nextNeedsTime+        t0 <- getCurrentTime+        nullFrame <- makeStableName undefined+        initialStateName <- makeStableName $! initial+        go t0 nullFrame initialStateName True++runInspect ::+       s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()+runInspect = run++runPauseable ::+       Wrapped s+    -> (Double -> s -> s)+    -> (Wrapped s -> [Control s])+    -> (s -> Picture)+    -> IO ()+runPauseable initial stepHandler controls drawHandler =+    run initial+        (wrappedStep stepHandler)+        (wrappedEvent controls stepHandler)+        (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+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 interaction, animation and simulation interfaces+interactionOf initial step event draw = runInspect initial step event draw++data Wrapped a = Wrapped+    { state :: a+    , paused :: Bool+    , mouseMovedTime :: Double+    } deriving (Show)++data Control :: * -> * where+    PlayButton :: Control a+    PauseButton :: Control a+    StepButton :: Control a+    RestartButton :: Control Double+    BackButton :: Control Double+    TimeLabel :: Control Double++wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a+wrappedStep f dt w =+    w+    { state =+          if paused w+              then state w+              else f dt (state w)+    , mouseMovedTime = mouseMovedTime w + dt+    }++wrappedEvent ::+       (Wrapped a -> [Control a])+    -> (Double -> a -> a)+    -> Event+    -> Wrapped a+    -> Wrapped a+wrappedEvent _ _ (MouseMovement _) w = w {mouseMovedTime = 0}+wrappedEvent ctrls f (MousePress LeftButton p) w =+    (foldr (handleControl f p) w (ctrls w)) {mouseMovedTime = 0}+wrappedEvent _ _ _ w = w++handleControl ::+       (Double -> a -> a) -> Point -> Control a -> Wrapped a -> Wrapped a+handleControl _ (x, y) RestartButton w+    | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6 = w {state = 0}+handleControl _ (x, y) PlayButton w+    | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {paused = False}+handleControl _ (x, y) PauseButton w+    | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {paused = True}+handleControl _ (x, y) BackButton w+    | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 =+        w {state = max 0 (state w - 0.1)}+handleControl f (x, y) StepButton w+    | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6 = w {state = f 0.1 (state w)}+handleControl _ _ _ w = w++wrappedDraw ::+       (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture+wrappedDraw ctrls f w = drawControlPanel ctrls w <> f (state w)++drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture+drawControlPanel ctrls w+    | alpha > 0 = pictures [drawControl w alpha c | c <- ctrls w]+    | otherwise = blank+  where+    alpha+        | mouseMovedTime w < 4.5 = 1+        | mouseMovedTime w < 5.0 = 10 - 2 * mouseMovedTime w+        | otherwise = 0++drawControl :: Wrapped a -> Double -> Control a -> Picture+drawControl _ alpha RestartButton = translated (-9) (-9) p+  where+    p =+        colored+            (RGBA 0 0 0 alpha)+            (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>+             translated 0.173 (-0.1) (solidRectangle 0.17 0.17)) <>+        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha PlayButton = translated (-8) (-9) p+  where+    p =+        colored+            (RGBA 0 0 0 alpha)+            (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 0)]) <>+        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha PauseButton = translated (-8) (-9) p+  where+    p =+        colored+            (RGBA 0 0 0 alpha)+            (translated (-0.15) 0 (solidRectangle 0.2 0.6) <>+             translated 0.15 0 (solidRectangle 0.2 0.6)) <>+        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha BackButton = translated (-7) (-9) p+  where+    p =+        colored+            (RGBA 0 0 0 alpha)+            (translated 0.15 0 (solidRectangle 0.2 0.5) <>+             solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]) <>+        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha StepButton = translated (-6) (-9) p+  where+    p =+        colored+            (RGBA 0 0 0 alpha)+            (translated (-0.15) 0 (solidRectangle 0.2 0.5) <>+             solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]) <>+        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl w alpha TimeLabel = translated 8 (-9) p+  where+    p =+        colored+            (RGBA 0 0 0 alpha)+            (scaled 0.5 0.5 $ text (pack (showFFloatAlt (Just 4) (state w) "s"))) <>+        colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8) <>+        colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)++animationControls :: Wrapped Double -> [Control Double]+animationControls w+    | mouseMovedTime w > 5 = []+    | paused w && state w > 0 =+        [RestartButton, PlayButton, StepButton, BackButton, TimeLabel]+    | paused w = [RestartButton, PlayButton, StepButton, TimeLabel]+    | otherwise = [RestartButton, PauseButton, TimeLabel]++animationOf f = runPauseable initial (+) animationControls f+  where+    initial = Wrapped {state = 0, paused = False, mouseMovedTime = 1000}++simulationControls :: Wrapped w -> [Control w]+simulationControls w+    | mouseMovedTime w > 5 = []+    | paused w = [PlayButton, StepButton]+    | otherwise = [PauseButton]++simulationOf simInitial simStep simDraw =+    runPauseable initial simStep simulationControls simDraw+  where+    initial =+        Wrapped {state = simInitial, paused = False, mouseMovedTime = 1000}++trace msg x = unsafePerformIO $ do+    hPutStrLn stderr (T.unpack msg)+    return x++#ifdef ghcjs_HOST_OS++--- GHCJS implementation of tracing and error handling #endif

@@ -1,5 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+ {--  Copyright 2016 The CodeWorld Authors. All rights reserved.+  Copyright 2018 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.@@ -13,8 +15,6 @@   See the License for the specific language governing permissions and   limitations under the License. -}--{-# LANGUAGE DeriveGeneric #-} module CodeWorld.Event where  import CodeWorld.Picture (Point)@@ -55,11 +55,30 @@     * Cancel     * Help -}-data Event = KeyPress !Text-           | KeyRelease !Text-           | MousePress !MouseButton !Point-           | MouseRelease !MouseButton Point-           | MouseMovement !Point-  deriving (Eq, Show, Read)+data Event+    = KeyPress !Text+    | KeyRelease !Text+    | MousePress !MouseButton+                 !Point+    | MouseRelease !MouseButton+                   !Point+    | MouseMovement !Point+    deriving (Eq, Show, Read) -data MouseButton = LeftButton | MiddleButton | RightButton deriving (Eq, Show, Read)+data MouseButton+    = LeftButton+    | MiddleButton+    | RightButton+    deriving (Eq, Show, Read)++pattern PointerPress :: Point -> Event++pattern PointerPress p = MousePress LeftButton p++pattern PointerRelease :: Point -> Event++pattern PointerRelease p = MouseRelease LeftButton p++pattern PointerMovement :: Point -> Event++pattern PointerMovement p = MouseMovement p

@@ -1,5 +1,5 @@ {--  Copyright 2016 The CodeWorld Authors. All rights reserved.+  Copyright 2018 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.@@ -13,190 +13,265 @@   See the License for the specific language governing permissions and   limitations under the License. -}- module CodeWorld.Picture where  import CodeWorld.Color import Data.Monoid ((<>)) import Data.Text (Text, pack)+import GHC.Stack  type Point = (Double, Double)+ type Vector = (Double, Double) +vectorLength :: Vector -> Double+vectorLength (x, y) = sqrt (x ^ 2 + y ^ 2)++vectorDirection :: Vector -> Double+vectorDirection (x, y) = atan2 y x+ vectorSum :: Vector -> Vector -> Vector-vectorSum (x1,y1) (x2,y2) = (x1 + x2, y1 + y2)+vectorSum (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)  vectorDifference :: Vector -> Vector -> Vector-vectorDifference (x1,y1) (x2,y2) = (x1 - x2, y1 - y2)+vectorDifference (x1, y1) (x2, y2) = (x1 - x2, y1 - y2)  scaledVector :: Double -> Vector -> Vector-scaledVector k (x,y) = (k*x, k*y)+scaledVector k (x, y) = (k * x, k * y)  {-| Angle is in radians -} rotatedVector :: Double -> Vector -> Vector-rotatedVector angle (x,y) = (x * cos angle - y * sin angle,-                             x * sin angle + y * cos angle)+rotatedVector angle (x, y) =+    (x * cos angle - y * sin angle, x * sin angle + y * cos angle)  dotProduct :: Vector -> Vector -> Double dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 -data Picture = Polygon [Point] !Bool-             | Path [Point] !Double !Bool !Bool-             | Sector !Double !Double !Double-             | Arc !Double !Double !Double !Double-             | Text !TextStyle !Font !Text-             | Color !Color !Picture-             | Translate !Double !Double !Picture-             | Scale !Double !Double !Picture-             | Rotate !Double !Picture-             | Pictures [Picture]-             | Logo+data Picture+    = Polygon CallStack+              [Point]+              !Bool+    | Path CallStack+           [Point]+           !Double+           !Bool+           !Bool+    | Sector CallStack+             !Double+             !Double+             !Double+    | Arc CallStack+          !Double+          !Double+          !Double+          !Double+    | Text CallStack+           !TextStyle+           !Font+           !Text+    | Color CallStack+            !Color+            !Picture+    | Translate CallStack+                !Double+                !Double+                !Picture+    | Scale CallStack+            !Double+            !Double+            !Picture+    | Rotate CallStack+             !Double+             !Picture+    | CoordinatePlane CallStack+    | Logo CallStack+    | Pictures [Picture] -data TextStyle = Plain | Bold | Italic+data TextStyle+    = Plain+    | Bold+    | Italic -data Font = SansSerif | Serif | Monospace | Handwriting | Fancy | NamedFont !Text+data Font+    = SansSerif+    | Serif+    | Monospace+    | Handwriting+    | Fancy+    | NamedFont !Text  -- | A blank picture blank :: Picture blank = Pictures []  -- | A thin sequence of line segments, with these points as endpoints-path :: [Point] -> Picture-path ps = Path ps 0 False False+polyline :: HasCallStack => [Point] -> Picture+polyline ps = Path callStack ps 0 False False +-- | A thin sequence of line segments, with these points as endpoints+path :: HasCallStack => [Point] -> Picture+path ps = Path callStack ps 0 False False++{-# WARNING path "Please use polyline instead of path." #-}+ -- | A thick sequence of line segments, with given line width and endpoints-thickPath :: Double -> [Point] -> Picture-thickPath n ps = Path ps n False False+thickPolyline :: HasCallStack => Double -> [Point] -> Picture+thickPolyline n ps = Path callStack ps n False False +-- | A thick sequence of line segments, with given line width and endpoints+thickPath :: HasCallStack => Double -> [Point] -> Picture+thickPath n ps = Path callStack ps n False False++{-# WARNING thickPath "Please used thickPolyline instead of thickPath." #-}+ -- | A thin polygon with these points as vertices-polygon :: [Point] -> Picture-polygon ps = Path ps 0 True False+polygon :: HasCallStack => [Point] -> Picture+polygon ps = Path callStack ps 0 True False  -- | A thick polygon with this line width and these points as -- vertices-thickPolygon :: Double -> [Point] -> Picture-thickPolygon n ps = Path ps n True False+thickPolygon :: HasCallStack => Double -> [Point] -> Picture+thickPolygon n ps = Path callStack ps n True False  -- | A solid polygon with these points as vertices-solidPolygon :: [Point] -> Picture-solidPolygon ps = Polygon ps False+solidPolygon :: HasCallStack => [Point] -> Picture+solidPolygon ps = Polygon callStack ps False  -- | A smooth curve passing through these points.-curve :: [Point] -> Picture-curve ps = Path ps 0 False True+curve :: HasCallStack => [Point] -> Picture+curve ps = Path callStack ps 0 False True  -- | A thick smooth curve with this line width, passing through these points.-thickCurve :: Double -> [Point] -> Picture-thickCurve n ps = Path ps n False True+thickCurve :: HasCallStack => Double -> [Point] -> Picture+thickCurve n ps = Path callStack ps n False True --- | A smooth closed loop passing through these points.-loop :: [Point] -> Picture-loop ps = Path ps 0 True True+-- | A smooth closed curve passing through these points.+closedCurve :: HasCallStack => [Point] -> Picture+closedCurve ps = Path callStack ps 0 True True --- | A thick smooth closed loop with this line width, passing through these points.-thickLoop :: Double -> [Point] -> Picture-thickLoop n ps = Path ps n True True+-- | A smooth closed curve passing through these points.+loop :: HasCallStack => [Point] -> Picture+loop ps = Path callStack ps 0 True True --- | A solid smooth closed loop passing through these points.-solidLoop :: [Point] -> Picture-solidLoop ps = Polygon ps True+{-# WARNING loop "Please use closedCurve instead of loop." #-} +-- | A thick smooth closed curve with this line width, passing through these points.+thickClosedCurve :: HasCallStack => Double -> [Point] -> Picture+thickClosedCurve n ps = Path callStack ps n True True++-- | A thick smooth closed curve with this line width, passing through these points.+thickLoop :: HasCallStack => Double -> [Point] -> Picture+thickLoop n ps = Path callStack ps n True True++{-# WARNING thickLoop "Please use thickClosedCurve instead of thickLoop." #-}++-- | A solid smooth closed curve passing through these points.+solidClosedCurve :: HasCallStack => [Point] -> Picture+solidClosedCurve ps = Polygon callStack ps True++-- | A solid smooth closed curve passing through these points.+solidLoop :: HasCallStack => [Point] -> Picture+solidLoop ps = Polygon callStack ps True++{-# WARNING solidLoop "Please use solidClosedCurve instead of solidLoop." #-}+ -- | A thin rectangle, with this width and height-rectangle :: Double -> Double -> Picture-rectangle w h = polygon [-    (-w/2, -h/2), (w/2, -h/2), (w/2, h/2), (-w/2, h/2)-    ]+rectangle :: HasCallStack => Double -> Double -> Picture+rectangle w h =+    polygon [(-w / 2, -h / 2), (w / 2, -h / 2), (w / 2, h / 2), (-w / 2, h / 2)]  -- | A solid rectangle, with this width and height-solidRectangle :: Double -> Double -> Picture-solidRectangle w h = solidPolygon [-    (-w/2, -h/2), (w/2, -h/2), (w/2, h/2), (-w/2, h/2)-    ]+solidRectangle :: HasCallStack => Double -> Double -> Picture+solidRectangle w h =+    solidPolygon+        [(-w / 2, -h / 2), (w / 2, -h / 2), (w / 2, h / 2), (-w / 2, h / 2)]  -- | A thick rectangle, with this line width, and width and height-thickRectangle :: Double -> Double -> Double -> Picture-thickRectangle lw w h = thickPolygon lw [-    (-w/2, -h/2), (w/2, -h/2), (w/2, h/2), (-w/2, h/2)-    ]+thickRectangle :: HasCallStack => Double -> Double -> Double -> Picture+thickRectangle lw w h =+    thickPolygon+        lw+        [(-w / 2, -h / 2), (w / 2, -h / 2), (w / 2, h / 2), (-w / 2, h / 2)]  -- | A thin circle, with this radius-circle :: Double -> Picture-circle = arc 0 (2*pi)+circle :: HasCallStack => Double -> Picture+circle = arc 0 (2 * pi)  -- | A thick circle, with this line width and radius-thickCircle :: Double -> Double -> Picture-thickCircle w = thickArc w 0 (2*pi)+thickCircle :: HasCallStack => Double -> Double -> Picture+thickCircle w = thickArc w 0 (2 * pi)  -- | A thin arc, starting and ending at these angles, with this radius -- -- Angles are in radians.-arc :: Double -> Double -> Double -> Picture-arc b e r = Arc b e r 0+arc :: HasCallStack => Double -> Double -> Double -> Picture+arc b e r = Arc callStack b e r 0  -- | A thick arc with this line width, starting and ending at these angles, -- with this radius. -- -- Angles are in radians.-thickArc :: Double -> Double -> Double -> Double -> Picture-thickArc w b e r = Arc b e r w+thickArc :: HasCallStack => Double -> Double -> Double -> Double -> Picture+thickArc w b e r = Arc callStack b e r w  -- | A solid circle, with this radius-solidCircle :: Double -> Picture-solidCircle = sector 0 (2*pi)+solidCircle :: HasCallStack => Double -> Picture+solidCircle = sector 0 (2 * pi)  -- | A solid sector of a circle (i.e., a pie slice) starting and ending at these -- angles, with this radius -- -- Angles are in radians.-sector :: Double -> Double -> Double -> Picture-sector = Sector+sector :: HasCallStack => Double -> Double -> Double -> Picture+sector = Sector callStack  -- | A piece of text-text :: Text -> Picture-text = Text Plain Serif+text :: HasCallStack => Text -> Picture+text = Text callStack Plain Serif -styledText :: TextStyle -> Font -> Text -> Picture-styledText = Text+styledText :: HasCallStack => TextStyle -> Font -> Text -> Picture+styledText = Text callStack  -- | A picture drawn entirely in this color.-colored :: Color -> Picture -> Picture-colored = Color+colored :: HasCallStack => Color -> Picture -> Picture+colored = Color callStack  -- | A picture drawn entirely in this colour.-coloured :: Color -> Picture -> Picture+coloured :: HasCallStack => Color -> Picture -> Picture coloured = colored  -- | A picture drawn translated in these directions.-translated :: Double -> Double -> Picture -> Picture-translated = Translate+translated :: HasCallStack => Double -> Double -> Picture -> Picture+translated = Translate callStack  -- | A picture scaled by these factors.-scaled :: Double -> Double -> Picture -> Picture-scaled = Scale+scaled :: HasCallStack => Double -> Double -> Picture -> Picture+scaled = Scale callStack  -- | A picture scaled by these factors.-dilated :: Double -> Double -> Picture -> Picture-dilated = scaled+dilated :: HasCallStack => Double -> Picture -> Picture+dilated k = scaled k k  -- | A picture rotated by this angle. -- -- Angles are in radians.-rotated :: Double -> Picture -> Picture-rotated = Rotate+rotated :: HasCallStack => Double -> Picture -> Picture+rotated = Rotate callStack  -- A picture made by drawing these pictures, ordered from top to bottom. pictures :: [Picture] -> Picture pictures = Pictures  instance Monoid Picture where-  mempty                   = blank-  mappend a (Pictures bs)  = Pictures (a:bs)-  mappend a b              = Pictures [a, b]-  mconcat                  = pictures+    mempty = blank+    mappend a (Pictures bs) = Pictures (a : bs)+    mappend a b = Pictures [a, b]+    mconcat = pictures  -- | Binary composition of pictures. (&) :: Picture -> Picture -> Picture infixr 0 &+ (&) = mappend  -- | A coordinate plane.  Adding this to your pictures can help you measure distances@@ -204,23 +279,11 @@ -- -- Example: -----    main = pictureOf (myPicture <> coordinatePlane)+--    main = drawingOf (myPicture <> coordinatePlane) --    myPicture = ...-coordinatePlane :: Picture-coordinatePlane = axes <> numbers <> guidelines-  where xline y     = thickPath 0.01 [(-10, y), (10, y)]-        xaxis       = thickPath 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 (text (pack (show k))))-              | k <- [-9, -8 .. 9], k /= 0 ]-        ynumbers = pictures-            [ translated 0.3 (fromIntegral k) (scaled 0.5 0.5 (text (pack (show k))))-              | k <- [-9, -8 .. 9], k /= 0 ]+coordinatePlane :: HasCallStack => Picture+coordinatePlane = CoordinatePlane callStack  -- | The CodeWorld logo.-codeWorldLogo :: Picture-codeWorldLogo = Logo+codeWorldLogo :: HasCallStack => Picture+codeWorldLogo = Logo callStack