codeworld-api 0.2.5 → 0.3
raw patch · 12 files changed
+2809/−2763 lines, 12 filesdep ~containerssetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers
API changes (from Hackage documentation)
- CodeWorld: LeftButton :: MouseButton
- CodeWorld: MiddleButton :: MouseButton
- CodeWorld: MouseMovement :: !Point -> Event
- CodeWorld: MousePress :: !MouseButton -> !Point -> Event
- CodeWorld: MouseRelease :: !MouseButton -> !Point -> Event
- CodeWorld: RightButton :: MouseButton
- CodeWorld: data MouseButton
+ CodeWorld: PointerMovement :: !Point -> Event
+ CodeWorld: PointerPress :: !Point -> Event
+ CodeWorld: PointerRelease :: !Point -> Event
+ CodeWorld: pattern Black :: Color
+ CodeWorld: pattern Blue :: Color
+ CodeWorld: pattern Brown :: Color
+ CodeWorld: pattern Gray :: Color
+ CodeWorld: pattern Green :: Color
+ CodeWorld: pattern Grey :: Color
+ CodeWorld: pattern HSL :: Double -> Double -> Double -> Color
+ CodeWorld: pattern Orange :: Color
+ CodeWorld: pattern Pink :: Color
+ CodeWorld: pattern Purple :: Color
+ CodeWorld: pattern RGB :: Double -> Double -> Double -> Color
+ CodeWorld: pattern Red :: Color
+ CodeWorld: pattern White :: Color
+ CodeWorld: pattern Yellow :: Color
- CodeWorld: (&) :: Picture -> Picture -> Picture
+ CodeWorld: (&) :: HasCallStack => Picture -> Picture -> Picture
- CodeWorld: gray :: Double -> Color
+ CodeWorld: gray :: Color
- CodeWorld: grey :: Double -> Color
+ CodeWorld: grey :: Color
- CodeWorld: mixed :: Color -> Color -> Color
+ CodeWorld: mixed :: [Color] -> Color
- CodeWorld: pictures :: [Picture] -> Picture
+ CodeWorld: pictures :: HasCallStack => [Picture] -> Picture
Files
- Setup.hs +1/−1
- codeworld-api.cabal +4/−3
- jsbits/sim_fp.js +209/−0
- src/CodeWorld.hs +13/−5
- src/CodeWorld/App.hs +1/−1
- src/CodeWorld/App2.hs +1/−1
- src/CodeWorld/CanvasM.hs +1/−1
- src/CodeWorld/CollaborationUI.hs +8/−8
- src/CodeWorld/Color.hs +113/−55
- src/CodeWorld/Driver.hs +2386/−2605
- src/CodeWorld/Event.hs +4/−30
- src/CodeWorld/Picture.hs +68/−53
Setup.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
codeworld-api.cabal view
@@ -1,11 +1,11 @@ Name: codeworld-api-Version: 0.2.5+Version: 0.3 Synopsis: Graphics library for CodeWorld License: Apache License-file: LICENSE Author: The CodeWorld Authors Maintainer: Chris Smith <cdsmith@gmail.com>-Copyright: (c) 2018, The CodeWorld Authors+Copyright: (c) 2019, The CodeWorld Authors Bug-reports: https://github.com/google/codeworld/issues Build-type: Simple Cabal-version: >=1.8@@ -31,7 +31,7 @@ CodeWorld.Driver CodeWorld.CollaborationUI Build-depends: base >= 4.9 && < 5,- containers >= 0.5.7 && < 0.6,+ containers >= 0.5.7 && < 0.7, hashable >= 1.2.4 && < 1.3, text >= 1.2.2 && < 1.3, mtl >= 2.2.1 && < 2.3,@@ -42,6 +42,7 @@ ghc-prim >= 0.3.1 && < 0.6 if impl(ghcjs)+ Js-sources: jsbits/sim_fp.js Build-depends: ghcjs-base, ghcjs-prim,
+ jsbits/sim_fp.js view
@@ -0,0 +1,209 @@+/*+ * Copyright 2019 The CodeWorld Authors. All rights reserved.+ *+ * Licensed under the Apache License, Version 2.0 (the "License");+ * you may not use this file except in compliance with the License.+ * You may obtain a copy of the License at+ *+ * http://www.apache.org/licenses/LICENSE-2.0+ *+ * Unless required by applicable law or agreed to in writing, software+ * distributed under the License is distributed on an "AS IS" BASIS,+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ * See the License for the specific language governing permissions and+ * limitations under the License.+ */++// Replaces JavaScript's Math module with deterministic implementations+// of all transcendental and other potentially under-specified values.+// The intent of this is to make it safer to run distributed+// computations and rely on getting the same result in all clients.+//+// This may (and likely will) make some floating point operations less+// accurate!+function cw$deterministic_math() {+ Math.E = 2.718281828459045;+ Math.LN10 = 2.302585092994046;+ Math.LN2 = 0.6931471805599453;+ Math.LOG10E = 0.4342944819032518;+ Math.LOG2E = 1.4426950408889634;+ Math.PI = 3.141592653589793;+ Math.SQRT1_2 = 0.7071067811865476;+ Math.SQRT2 = 1.4142135623730951;++ Math.cbrt = function(x) {+ return Math.pow(x, 1.0 / 3.0);+ }++ Math.exp = function(x) {+ if (x < 2) {+ // Compute using the power series.+ var term = 1;+ var sum = 1;+ for (var i = 1; term > 1e-10; ++i) {+ term *= x / i;+ sum += term;+ }+ return sum;+ }++ var sqrt = Math.exp(x/2);+ return sqrt * sqrt;+ }++ Math.expm1 = function(x) {+ return Math.exp(x) - 1;+ }++ Math.asin = function(x) {+ if (x < 0) return -Math.asin(-x);++ // Accurate to about 5 decimal places. Should use a better approximation.+ var a0 = 1.5707288;+ var a1 = -0.2121144;+ var a2 = 0.0742610;+ var a3 = -0.0187293;++ var x2 = x * x;+ var x3 = x2 * x;++ return Math.PI / 2 - Math.sqrt(1 - x) * (a0 + a1 * x + a2 * x2 + a3 * x3);+ }++ Math.acos = function(x) {+ return Math.PI / 2 - Math.asin(x);+ }++ Math.atan = function(x) {+ if (Math.abs(x) > 1) return Math.sign(x) * Math.PI / 2 - Math.atan(1 / x);++ // Accurate to about 5 decimal places. Should use a better approximation.+ var a1 = 0.9998660;+ var a3 = -0.3302995;+ var a5 = 0.1801410;+ var a7 = -0.0851330;+ var a9 = 0.0208351;++ var x2 = x * x;+ var x3 = x * x2;+ var x5 = x3 * x2;+ var x7 = x5 * x2;+ var x9 = x7 * x2;++ return a1 * x + a3 * x3 + a5 * x5 + a7 * x7 + a9 * x9;+ }++ Math.atan2 = function(y, x) {+ if (x == 0 && y > 0) return Math.PI / 2;+ if (x == 0 && y < 0) return -Math.PI / 2;+ var atan = Math.atan(y / x);+ if (x > 0) return atan;+ if (atan > 0) return atan - Math.PI;+ return atan + Math.PI;+ }++ Math.asinh = function(x) {+ return Math.log(x + Math.sqrt(x * x + 1));+ }++ Math.acosh = function(x) {+ return Math.log(x + Math.sqrt(x * x - 1));+ }++ Math.atanh = function(x) {+ return Math.log((1 + x) / (1 - x)) / 2;+ }++ Math.cos = function(x) {+ return Math.sin(x + Math.PI / 2);+ }++ Math.cosh = function(x) {+ return (Math.exp(z) + Math.exp(-z)) / 2;+ }++ Math.hypot = function() {+ var sumsq = 0;+ for (var i = 0; i < arguments.length; i++) {+ var x = arguments[i];+ sumsq += x * x;+ }+ return Math.sqrt(sumsq);+ }++ Math.log = function(x) {+ var float = new Float64Array(1);+ var bytes = new Uint8Array(float.buffer);+ float[0] = x;++ var exponent = ((bytes[7] & 0x7f) << 4 | bytes[6] >> 4) - 0x3ff;++ bytes[7] = 0x3f;+ bytes[6] |= 0xf0;+ var mantissa = float[0];++ var lg2;+ var a = 4.418508;+ var b = 9.143698;+ var c = 6.232189;+ var d = 6.337977;+ if (mantissa > 1.5) {+ var k = mantissa / 2 - 1;+ lg2 = exponent + 1 + (a * k * k + b * k) / (k * k + c * k + d);+ } else {+ var k = mantissa - 1;+ lg2 = exponent + (a * k * k + b * k) / (k * k + c * k + d);+ }+ return lg2 / Math.LOG2E;+ }++ Math.log1p = function(x) {+ return Math.log(1 + x);+ }++ Math.log10 = function(x) {+ return Math.log(x) / Math.LN10;+ }++ Math.log2 = function(x) {+ return Math.log(x) / Math.LN2;+ }++ Math.pow = function(base, exponent) {+ if (exponent < 0) {+ return 1 / Math.pow(base, -exponent);+ } else if (Math.floor(exponent) == exponent && exponent < 100) {+ // Exact implementation for small integer powers.+ function ipow(n) {+ if (n == 0) return 1;+ if (n % 2 == 1) return base * ipow(n - 1);+ var sqrt = ipow(n / 2);+ return sqrt * sqrt;+ }+ return ipow(exponent);+ } else if (base == 0) {+ return 0;+ } else {+ return Math.exp(exponent * Math.log(base));+ }+ }++ Math.sin = function(x) {+ if (x < -Math.PI) return Math.sin(x + 2 * Math.PI);+ if (x > Math.PI) return Math.sin(x - 2 * Math.PI);+ var t = 1.27323954 * x - 0.405284735 * x * Math.abs(x);+ return 0.225 * t * (Math.abs(t) - 1) + t;+ }++ Math.sinh = function(x) {+ return (Math.exp(z) - Math.exp(-z)) / 2;+ }++ Math.tan = function(x) {+ return Math.sin(x) / Math.cos(x);+ }++ Math.tanh = function(x) {+ return Math.sinh(x) / Math.cosh(x);+ }+}
src/CodeWorld.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -122,12 +122,20 @@ , saturation , luminosity , alpha+ , pattern White+ , pattern Black+ , pattern Gray+ , pattern Grey+ , pattern Red+ , pattern Orange+ , pattern Yellow+ , pattern Green+ , pattern Blue+ , pattern Purple+ , pattern Pink+ , pattern Brown -- * Events , Event(..)- , MouseButton(..)- , pattern PointerPress- , pattern PointerRelease- , pattern PointerMovement -- * Debugging , trace ) where
src/CodeWorld/App.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE KindSignatures #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/CodeWorld/App2.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE KindSignatures #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/CodeWorld/CanvasM.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at
src/CodeWorld/CollaborationUI.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE ViewPatterns #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -170,7 +170,7 @@ 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 &+ translated 0 2 (lettering "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) &@@ -179,9 +179,9 @@ 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 2 (lettering "Share this key with other players:") & translated 0 4 (playerDots numPlayers present) &- letterBoxes (gray 0.8) code &+ letterBoxes (HSL 0 0 0.8) code & button "Cancel" (dull yellow) 0 (-3) 8 2 mousePos & connectScreen "Waiting" time @@ -195,7 +195,7 @@ letterBox :: Color -> Text -> Picture letterBox c t =- thickRectangle 0.1 1.5 1.5 & text t & colored c (solidRectangle 1.5 1.5)+ thickRectangle 0.1 1.5 1.5 & lettering t & colored c (solidRectangle 1.5 1.5) pad :: Int -> a -> [a] -> [a] pad 0 _ xs = xs@@ -210,7 +210,7 @@ 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 white (styledLettering Plain SansSerif txt) & colored color (roundRect w h) where color@@ -227,7 +227,7 @@ ] playerDots n m- | n > 8 = text $ T.pack $ show m ++ " / " ++ show n+ | n > 8 = lettering $ T.pack $ show m ++ " / " ++ show n playerDots n m = pictures [ translated@@ -247,7 +247,7 @@ & translated 0 5 codeWorldLogo & colored background (solidRectangle 20 20) where- connectBox = scaled 2 2 (text hdr)+ connectBox = scaled 2 2 (lettering hdr) & rectangle 14 3 & colored connectColor (solidRectangle 14 3) connectColor = let k = (1 + sin (3 * t)) / 5
src/CodeWorld/Color.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE ViewPatterns #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -75,55 +75,13 @@ 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 = HSL (0 / 3 * pi) 0.75 0.5--yellow = HSL (1 / 3 * pi) 0.75 0.5--green = HSL (2 / 3 * pi) 0.75 0.5--cyan = HSL (3 / 3 * pi) 0.75 0.5--blue = HSL (4 / 3 * pi) 0.75 0.5--magenta = HSL (5 / 3 * pi) 0.75 0.5---- Tertiary colors-orange, rose, chartreuse, aquamarine, violet, azure :: Color-orange = HSL (1 / 6 * pi) 0.75 0.5--chartreuse = HSL (3 / 6 * pi) 0.75 0.5--aquamarine = HSL (5 / 6 * pi) 0.75 0.5--azure = HSL (7 / 6 * pi) 0.75 0.5--violet = HSL (9 / 6 * pi) 0.75 0.5--rose = HSL (11 / 6 * pi) 0.75 0.5---- Other common colors and color names-brown = HSL (1 / 6 * pi) 0.5 0.5--purple = violet--pink = lighter 0.25 rose--mixed :: Color -> Color -> Color-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+mixed :: [Color] -> Color+mixed colors = go 0 0 0 0 0 colors+ where go rr gg bb aa n ((fenceColor -> RGBA r g b a) : cs) =+ go (rr + r^2 * a) (gg + g^2 * a) (bb + b^2 * a) (aa + a) (n + 1) cs+ go rr gg bb aa n []+ | aa == 0 = RGBA 0 0 0 0+ | otherwise = RGBA (sqrt (rr/aa)) (sqrt (gg/aa)) (sqrt (bb/aa)) (aa/n) -- Helper function that sets the alpha of the second color to that -- of the first@@ -160,11 +118,6 @@ translucent :: Color -> Color translucent (fenceColor -> RGBA r g b a) = RGBA r g b (a / 2) -gray, grey :: Double -> Color-gray = grey--grey (fence -> k) = RGBA k k k 1- -- | An infinite list of colors. assortedColors :: [Color] assortedColors = [ HSL (adjusted h) 0.75 0.5 | h <- [0, 2 * pi / phi ..] ]@@ -214,3 +167,108 @@ alpha :: Color -> Double alpha (RGBA r g b a) = fence a++-- New-style colors++pattern White :: Color+pattern White = HSL 0.00 0.00 1.00++pattern Black :: Color+pattern Black = HSL 0.00 0.00 0.00++pattern Gray :: Color+pattern Gray = HSL 0.00 0.00 0.50++pattern Grey :: Color+pattern Grey = HSL 0.00 0.00 0.50++pattern Red :: Color+pattern Red = HSL 0.00 0.75 0.50++pattern Orange :: Color+pattern Orange = HSL 0.61 0.75 0.50++pattern Yellow :: Color+pattern Yellow = HSL 0.98 0.75 0.50++pattern Green :: Color+pattern Green = HSL 2.09 0.75 0.50++pattern Blue :: Color+pattern Blue = HSL 3.84 0.75 0.50++pattern Purple :: Color+pattern Purple = HSL 4.80 0.75 0.50++pattern Pink :: Color+pattern Pink = HSL 5.76 0.75 0.75++pattern Brown :: Color+pattern Brown = HSL 0.52 0.60 0.40++-- Old-style colors++white, black, red, green, blue, cyan, magenta, yellow :: Color+orange, rose, chartreuse, aquamarine, violet, azure :: Color+gray, grey :: Color++white = White+black = Black+red = Red+yellow = Yellow+green = Green+blue = Blue+orange = Orange+brown = Brown+purple = Purple+pink = Pink+gray = Gray+grey = Grey++cyan = HSL (3 / 3 * pi) 0.75 0.5+magenta = HSL (5 / 3 * pi) 0.75 0.5+chartreuse = HSL (3 / 6 * pi) 0.75 0.5+aquamarine = HSL (5 / 6 * pi) 0.75 0.5+azure = HSL (7 / 6 * pi) 0.75 0.5+violet = HSL (9 / 6 * pi) 0.75 0.5+rose = HSL (11 / 6 * pi) 0.75 0.5++{-# WARNING White [ "Please use white (lower case) instead of White."+ , "The value White may be removed July 2019." ] #-}+{-# WARNING Black [ "Please use black (lower case) instead of Black."+ , "The value Black may be removed July 2019." ] #-}+{-# WARNING Red [ "Please use red (lower case) instead of Red."+ , "The value Red may be removed July 2019." ] #-}+{-# WARNING Green [ "Please use green (lower case) instead of Green."+ , "The value Green may be removed July 2019." ] #-}+{-# WARNING Blue [ "Please use blue (lower case) instead of Blue."+ , "The value Blue may be removed July 2019." ] #-}+{-# WARNING Yellow [ "Please use yellow (lower case) instead of Yellow."+ , "The value Yellow may be removed July 2019." ] #-}+{-# WARNING Orange [ "Please use orange (lower case) instead of Orange."+ , "The value Orange may be removed July 2019." ] #-}+{-# WARNING Brown [ "Please use brown (lower case) instead of Brown."+ , "The value Brown may be removed July 2019." ] #-}+{-# WARNING Purple [ "Please use purple (lower case) instead of Purple."+ , "The value Purple may be removed July 2019." ] #-}+{-# WARNING Pink [ "Please use pink (lower case) instead of Pink."+ , "The value Pink may be removed July 2019." ] #-}+{-# WARNING Gray [ "Please use gray (lower case) instead of Gray."+ , "The value Gray may be removed July 2019." ] #-}+{-# WARNING Grey [ "Please use grey (lower case) instead of Grey."+ , "The value Grey may be removed July 2019." ] #-}++{-# WARNING magenta [ "Please use the RGB function instead of magenta."+ , "The variable magenta may be removed July 2020." ] #-}+{-# WARNING cyan [ "Please use the RGB function instead of cyan."+ , "The variable cyan may be removed July 2020." ] #-}+{-# WARNING chartreuse [ "Please use the RGB function instead of chartreuse."+ , "The variable chartreuse may be removed July 2020." ] #-}+{-# WARNING aquamarine [ "Please use the RGB function instead of aquamarine."+ , "The variable aquamarine may be removed July 2020." ] #-}+{-# WARNING azure [ "Please use the RGB function instead of azure."+ , "The variable azure may be removed July 2020." ] #-}+{-# WARNING rose [ "Please use the RGB function instead of rose."+ , "The variable rose may be removed July 2020." ] #-}+{-# WARNING violet [ "Please use Purple instead of violet."+ , "The variable violet may be removed July 2020." ] #-}
src/CodeWorld/Driver.hs view
@@ -17,2611 +17,2392 @@ {-# 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- , activityOf- , debugActivityOf- , groupActivityOf- , unsafeGroupActivityOf- , simulationOf- , debugSimulationOf- , interactionOf- , debugInteractionOf- , collaborationOf- , unsafeCollaborationOf- , trace- ) where--import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)-import qualified CodeWorld.CollaborationUI as CUI-import qualified CodeWorld.CanvasM as CM-import CodeWorld.CanvasM (CanvasM, runCanvasM)-import CodeWorld.Color-import CodeWorld.Event-import CodeWorld.Picture-import Control.Concurrent-import Control.Concurrent.Chan-import Control.Concurrent.MVar-import Control.Exception-import Control.Monad-import Control.Monad.Trans (liftIO)-import Data.Char (chr)-import Data.List (find, zip4, intercalate)-import Data.Maybe (fromMaybe, isNothing, mapMaybe)-import Data.Monoid-import Data.Serialize-import Data.Serialize.Text-import qualified Data.Text as T-import Data.Text (Text, pack, singleton)-import qualified Debug.Trace-import GHC.Fingerprint.Type-import GHC.Generics-import GHC.Prim-import GHC.Stack-import GHC.StaticPtr-import Numeric-import System.Environment-import System.IO-import System.IO.Unsafe-import System.Mem.StableName-import System.Random-import Text.Printf-import Text.Read-#ifdef ghcjs_HOST_OS-import CodeWorld.Message-import CodeWorld.Prediction-import qualified Control.Monad.Trans.State as State-import Data.Hashable-import Data.IORef-import qualified Data.JSString-import Data.JSString.Text-import Data.Word-import GHCJS.Concurrent (withoutPreemption)-import GHCJS.DOM-import qualified GHCJS.DOM.ClientRect as ClientRect-import GHCJS.DOM.Document-import GHCJS.DOM.Element-import GHCJS.DOM.EventM-import GHCJS.DOM.GlobalEventHandlers hiding (error)-import GHCJS.DOM.MouseEvent-import GHCJS.DOM.NonElementParentNode-import GHCJS.DOM.Types (Element, unElement)-import qualified GHCJS.DOM.Window as Window-import GHCJS.Foreign-import GHCJS.Foreign.Callback-import GHCJS.Marshal-import GHCJS.Marshal.Pure-import GHCJS.Types-import qualified JavaScript.Array as Array-import JavaScript.Object-import JavaScript.Web.AnimationFrame-import qualified JavaScript.Web.Canvas as Canvas-import qualified JavaScript.Web.Canvas.Internal as Canvas-import qualified JavaScript.Web.Location as Loc-import qualified JavaScript.Web.MessageEvent as WS-import qualified JavaScript.Web.WebSocket as WS-import Unsafe.Coerce-#else-import Data.Time.Clock-import qualified Graphics.Blank as Canvas-import Graphics.Blank (Canvas)-import Text.Printf-#endif------------------------------------------------------------------------------------- The common interface, provided by both implementations below.--- | Draws a 'Picture'. This is the simplest CodeWorld entry point.-drawingOf :: Picture -- ^ The picture to show on the screen.- -> IO ()---- | Shows an animation, with a picture for each time given by the parameter.-animationOf :: (Double -> Picture) -- ^ A function that produces animation- -- frames, given the time in seconds.- -> IO ()---- | Runs an interactive CodeWorld program that responds to events. Activities--- can interact with the user, change over time, and remember information about--- the past.-activityOf- :: world -- ^ The initial state of the interaction.- -> (Event -> world -> world) -- ^ The event handling function, which updates- -- the state given an event.- -> (world -> Picture) -- ^ The visualization function, which converts- -- the state into a picture to display.- -> IO ()---- | Runs an interactive CodeWorld program in debugging mode. In this mode,--- the program gets controls to pause and manipulate time, and even go back in--- time to look at past states.-debugActivityOf- :: world -- ^ The initial state of the interaction.- -> (Event -> world -> world) -- ^ The event handling function, which updates- -- the state given an event.- -> (world -> Picture) -- ^ The visualization function, which converts- -- the state into a picture to display.- -> IO ()---- | Runs an interactive multi-user CodeWorld program that is joined by several--- participants over the internet.-groupActivityOf- :: Int -- ^ The number of participants to expect. The participants will be- -- ^ numbered starting at 0.- -> StaticPtr (StdGen -> world)- -- ^ The initial state of the activity.- -> StaticPtr (Int -> Event -> world -> world)- -- ^ The event handling function, which updates the state given a- -- participant number and user interface event.- -> StaticPtr (Int -> world -> Picture)- -- ^ The visualization function, which converts a participant number- -- and the state into a picture to display.- -> IO ()---- | A version of 'groupActivityOf' that avoids static pointers, and does not--- check for consistency.-unsafeGroupActivityOf- :: Int -- ^ The number of participants to expect. The participants will be- -- ^ numbered starting at 0.- -> (StdGen -> world)- -- ^ The initial state of the activity.- -> (Int -> Event -> world -> world)- -- ^ The event handling function, which updates the state given a- -- participant number and user interface event.- -> (Int -> world -> Picture)- -- ^ The visualization function, which converts a participant number- -- and the state into a picture to display.- -> IO ()---- | Shows a simulation, which is essentially a continuous-time dynamical--- system described by an initial value and step function.-simulationOf- :: world -- ^ The initial state of the simulation.- -> (Double -> world -> world) -- ^ The time step function, which advances- -- the state given the time difference.- -> (world -> Picture) -- ^ The visualization function, which converts- -- the state into a picture to display.- -> IO ()--debugSimulationOf- :: world -- ^ The initial state of the simulation.- -> (Double -> world -> world) -- ^ The time step function, which advances- -- the state given the time difference.- -> (world -> Picture) -- ^ The visualization function, which converts- -- the state into a picture to display.- -> IO ()---- | Runs an interactive event-driven CodeWorld program. This is a--- generalization of simulations that can respond to events like key presses--- and mouse movement.-interactionOf- :: world -- ^ The initial state of the interaction.- -> (Double -> world -> world) -- ^ The time step function, which advances- -- the state given the time difference.- -> (Event -> world -> world) -- ^ The event handling function, which updates- -- the state given a user interface event.- -> (world -> Picture) -- ^ The visualization function, which converts- -- the state into a picture to display.- -> IO ()--debugInteractionOf- :: world -- ^ The initial state of the interaction.- -> (Double -> world -> world) -- ^ The time step function, which advances- -- the state given the time difference.- -> (Event -> world -> world) -- ^ The event handling function, which updates- -- the state given a user interface event.- -> (world -> Picture) -- ^ The visualization function, which converts- -- the state into a picture to display.- -> IO ()---- | Runs an interactive multi-user CodeWorld program, involving multiple--- participants over the internet.-collaborationOf- :: Int -- ^ The number of participants to expect. The participants will be- -- ^ numbered starting at 0.- -> StaticPtr (StdGen -> world)- -- ^ The initial state of the collaboration.- -> StaticPtr (Double -> world -> world)- -- ^ The time step function, which advances the state given the time- -- difference.- -> StaticPtr (Int -> Event -> world -> world)- -- ^ The event handling function, which updates the state given a- -- participant number and user interface event.- -> StaticPtr (Int -> world -> Picture)- -- ^ The visualization function, which converts a participant number- -- and the state into a picture to display.- -> IO ()---- | A version of 'collaborationOf' that avoids static pointers, and does not--- check for consistent parameters.-unsafeCollaborationOf- :: Int -- ^ The number of participants to expect. The participants will be- -- ^ numbered starting at 0.- -> (StdGen -> world)- -- ^ The initial state of the collaboration.- -> (Double -> world -> world)- -- ^ The time step function, which advances the state given the time- -- difference.- -> (Int -> Event -> world -> world)- -- ^ The event handling function, which updates the state given a- -- participant number and user interface event.- -> (Int -> world -> Picture)- -- ^ The visualization function, which converts a participant number- -- and the state into a picture to display.- -> IO ()---- | Prints a debug message to the CodeWorld console when a value is forced.--- This is equivalent to the similarly named function in `Debug.Trace`, except--- that it uses the CodeWorld console instead of standard output.-trace :: Text -> a -> a------------------------------------------------------------------------------------- A Drawing is an intermediate and simpler representation of a Picture, suitable--- for drawing. A drawing does not contain unnecessary metadata like CallStacks.--- The drawer is specific to the platform.-data Drawing- = Shape Drawer- | Transformation (DrawState -> DrawState)- Drawing- | Drawings [Drawing]--#if MIN_VERSION_base(4,11,0)--instance Semigroup Drawing where- a <> Drawings bs = Drawings (a : bs)- a <> b = Drawings [a, b]--#endif--instance Monoid Drawing where- mempty = Drawings []- mappend a (Drawings bs) = Drawings (a : bs)- mappend a b = Drawings [a, b]- mconcat = Drawings---- A DrawState is an affine transformation matrix, plus a Bool indicating whether--- a color has been chosen yet.-type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color)---- A NodeId a unique id for each node in a Picture of Drawing, chosen by the order--- the node appears in DFS. When a Picture is converted to a drawing the NodeId's of--- corresponding nodes are shared. Always >=0.-type NodeId = Int--pictureToDrawing :: Picture -> Drawing-pictureToDrawing (SolidClosedCurve _ pts) = Shape $ polygonDrawer pts True-pictureToDrawing (SolidPolygon _ pts) = Shape $ polygonDrawer pts False-pictureToDrawing (Polygon _ pts) = Shape $ pathDrawer pts 0 True False-pictureToDrawing (ThickPolygon _ pts w) = Shape $ pathDrawer pts w True False-pictureToDrawing (Rectangle _ w h) = Shape $ pathDrawer (rectangleVertices w h) 0 True False-pictureToDrawing (SolidRectangle _ w h) = Shape $ polygonDrawer (rectangleVertices w h) False-pictureToDrawing (ThickRectangle _ lw w h) = Shape $ pathDrawer (rectangleVertices w h) lw True False-pictureToDrawing (ClosedCurve _ pts) = Shape $ pathDrawer pts 0 True True-pictureToDrawing (ThickClosedCurve _ pts w) = Shape $ pathDrawer pts w True True-pictureToDrawing (Circle _ r) = Shape $ arcDrawer 0 (2 * pi) r 0-pictureToDrawing (SolidCircle _ r) = Shape $ sectorDrawer 0 (2 * pi) r -pictureToDrawing (ThickCircle _ lw r) = Shape $ arcDrawer 0 (2 * pi) r lw-pictureToDrawing (Polyline _ pts) = Shape $ pathDrawer pts 0 False False-pictureToDrawing (ThickPolyline _ pts w) = Shape $ pathDrawer pts w False False-pictureToDrawing (Curve _ pts) = Shape $ pathDrawer pts 0 False True-pictureToDrawing (ThickCurve _ pts w) = Shape $ pathDrawer pts w False True-pictureToDrawing (Sector _ b e r) = Shape $ sectorDrawer b e r-pictureToDrawing (Arc _ b e r) = Shape $ arcDrawer b e r 0-pictureToDrawing (ThickArc _ b e r w) = Shape $ arcDrawer b e r w-pictureToDrawing (Lettering _ txt) = Shape $ textDrawer Plain Serif txt-pictureToDrawing (Blank _) = Drawings $ []-pictureToDrawing (StyledLettering _ sty fnt txt) = Shape $ textDrawer sty fnt txt-pictureToDrawing (Logo _) = Shape $ logoDrawer-pictureToDrawing (CoordinatePlane _) = Shape $ coordinatePlaneDrawer-pictureToDrawing (Color _ col p) =- Transformation (setColorDS col) $ pictureToDrawing p-pictureToDrawing (Translate _ x y p) =- Transformation (translateDS x y) $ pictureToDrawing p-pictureToDrawing (Scale _ x y p) =- Transformation (scaleDS x y) $ pictureToDrawing p-pictureToDrawing (Dilate _ k p) =- Transformation (scaleDS k k) $ pictureToDrawing p-pictureToDrawing (Rotate _ r p) =- Transformation (rotateDS r) $ pictureToDrawing p-pictureToDrawing (Pictures ps) = Drawings $ pictureToDrawing <$> ps--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 :: DrawState -> CanvasM a -> CanvasM a-withDS (ta, tb, tc, td, te, tf, col) action = CM.saveRestore $ do- CM.transform ta tb tc td te tf- CM.beginPath- action--applyColor :: DrawState -> CanvasM ()-applyColor ds =- case getColorDS ds of- Nothing -> do- CM.strokeColor 0 0 0 1- CM.fillColor 0 0 0 1- Just (RGBA r g b a) -> do- CM.strokeColor- (round $ r * 255)- (round $ g * 255)- (round $ b * 255)- a- CM.fillColor- (round $ r * 255)- (round $ g * 255)- (round $ b * 255)- a--drawCodeWorldLogo ::- DrawState -> Int -> Int -> Int -> Int -> CanvasM ()-drawCodeWorldLogo ds x y w h = do- Just doc <- liftIO $ currentDocument- Just canvas <- liftIO $ getElementById doc ("cwlogo" :: JSString)- case getColorDS ds of- Nothing -> CM.drawImage (canvasFromElement canvas) x y w h- Just (RGBA r g b a)- -- This is a tough case. The best we can do is to allocate an- -- offscreen buffer as a temporary.- -> do- (img, _) <- CM.newImage w h $ do- applyColor ds- CM.fillRect 0 0 (fromIntegral w) (fromIntegral h)- CM.globalCompositeOperation "destination-in"- CM.drawImage (canvasFromElement canvas) 0 0 w h- CM.drawImage img x y w h---- 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- withScreen (elementFromCanvas offscreenCanvas) rect $- drawFrame (node <> coordinatePlaneDrawing)- 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- SolidPolygon cs pts -> do- obj <- init "solidPolygon"- ptsJS <- pointsToArr pts- setProps [("points", ptsJS), ("smooth", pToJSVal False)] obj- retVal obj- SolidClosedCurve cs pts -> do- obj <- init "solidClosedCurve"- ptsJS <- pointsToArr pts- setProps [("points", ptsJS), ("smooth", pToJSVal True)] obj- retVal obj- Polygon cs pts -> do- obj <- init "polygon"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal (0 :: Double))- , ("closed", pToJSVal True)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- ThickPolygon cs pts w -> do- obj <- init "thickPolygon"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal w)- , ("closed", pToJSVal True)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- Rectangle _ w h -> do- obj <- init "rectangle"- setProps- [ ("width", pToJSVal w)- , ("height", pToJSVal h)- , ("closed", pToJSVal True)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- SolidRectangle _ w h -> do- obj <- init "solidRectangle"- setProps - [ ("width", pToJSVal w)- , ("height", pToJSVal h)- , ("closed", pToJSVal True)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- ThickRectangle _ lw w h-> do- obj <- init "thickRectangle"- setProps- [- ("linewidth", pToJSVal lw)- , ("width", pToJSVal w)- , ("height", pToJSVal h)- , ("closed", pToJSVal True)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- ClosedCurve cs pts -> do- obj <- init "closedCurve"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal (0 :: Double))- , ("closed", pToJSVal True)- , ("smooth", pToJSVal True)- ]- obj- retVal obj- ThickClosedCurve cs pts w -> do- obj <- init "thickClosedCurve"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal w)- , ("closed", pToJSVal True)- , ("smooth", pToJSVal True)- ]- obj- retVal obj- Circle cs r -> do- obj <- init "circle"- setProps- [ ("radius", pToJSVal r)- , ("closed", pToJSVal True)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- SolidCircle cs r -> do- obj <- init "solidCircle"- setProps- [ ("radius", pToJSVal r)- , ("closed", pToJSVal True)- ]- obj- retVal obj- ThickCircle cs lw r -> do- obj <- init "thickCircle"- setProps- [ ("radius", pToJSVal r)- , ("linewidth", pToJSVal lw)- , ("endAngle", pToJSVal True)- , ("radius", pToJSVal False)- ]- obj- retVal obj- Polyline cs pts -> do- obj <- init "polyline"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal (0 :: Double))- , ("closed", pToJSVal False)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- ThickPolyline cs pts w -> do- obj <- init "thickPolyline"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal w)- , ("closed", pToJSVal False)- , ("smooth", pToJSVal False)- ]- obj- retVal obj- Curve cs pts -> do- obj <- init "curve"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal (0 :: Double))- , ("closed", pToJSVal False)- , ("smooth", pToJSVal True)- ]- obj- retVal obj- ThickCurve cs pts w -> do- obj <- init "thickCurve"- ptsJS <- pointsToArr pts- setProps- [ ("points", ptsJS)- , ("width", pToJSVal w)- , ("closed", pToJSVal False)- , ("smooth", pToJSVal True)- ]- 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 -> do- obj <- init "arc"- setProps- [ ("startAngle", pToJSVal b)- , ("endAngle", pToJSVal e)- , ("radius", pToJSVal r)- , ("width", pToJSVal (0 :: Double))- ]- obj- retVal obj- ThickArc cs b e r w -> do- obj <- init "thickArc"- setProps- [ ("startAngle", pToJSVal b)- , ("endAngle", pToJSVal e)- , ("radius", pToJSVal r)- , ("width", pToJSVal w)- ]- obj- retVal obj- Lettering cs txt -> do- obj <- init "lettering"- setProps- [ ("font", pToJSVal $ fontString Plain Serif)- , ("text", pToJSVal txt)- ]- obj- retVal obj- StyledLettering cs style font txt -> do- obj <- init "styledLettering"- 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- Dilate cs k p -> do- obj <- init "scale"- picJS <- picToObj' p- setProps- [("picture", picJS), ("k", pToJSVal k)]- 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- Blank cs -> init "blank" >>= 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--trim :: Int -> String -> String-trim x y = let mid = (x - 2) `div` 2- in case x >= (length y) of- True -> y :: String- False -> take mid y ++ ".." ++ (reverse $ take mid $ reverse y)--showShortFloat :: Double -> String-showShortFloat x = stripZeros (showFFloatAlt (Just 4) x "")- where stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse--describePicture :: Picture -> String-describePicture (Rectangle _ w h) =- "rectangle {" ++- " width = " ++ showShortFloat w ++- ", height = " ++ showShortFloat h ++- " }"-describePicture (SolidPolygon _ pts) =- "solidPolygon {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- " }"-describePicture (SolidClosedCurve _ pts) =- "solidClosedCurve {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- " }"-describePicture (Polygon _ pts) =- "polygon {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- " }"-describePicture (ThickPolygon _ pts w) =- "thickPolygon {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "], thickness = " ++ showShortFloat w ++- " }"-describePicture (ClosedCurve _ pts) =- "closedCurve {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- " }"-describePicture (ThickClosedCurve _ pts w) =- "thickClosedCurve {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- ", thickness = " ++ showShortFloat w ++- " }"-describePicture (Polyline _ pts) =- "polyline {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- " }"-describePicture (ThickPolyline _ pts w) =- "thickPolyline {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts ] ++- "]" ++- ", thickness = " ++ showShortFloat w ++- " }"-describePicture (Curve _ pts) =- "curve {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- " }"-describePicture (ThickCurve _ pts w) =- "thickCurve {" ++- " points = [" ++- intercalate ", " [- "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")"- | (x, y) <- pts- ] ++- "]" ++- ", thickness = " ++ showShortFloat w ++- " }"-describePicture (SolidRectangle _ w h) =- "solidRectangle {" ++- " width = " ++ showShortFloat w ++- ", height = " ++ showShortFloat h ++- " }"-describePicture (ThickRectangle _ lw w h) =- "thickRectangle {" ++- " thickness = " ++ showShortFloat lw ++- ", width = " ++ showShortFloat w ++- ", height = " ++ showShortFloat h ++- " }"-describePicture (Circle _ r) = "circle { radius = " ++ showShortFloat r ++ " }"-describePicture (SolidCircle _ r) =- "solidCircle { radius = " ++ showShortFloat r ++ " }"-describePicture (ThickCircle _ lw r) =- "thickCircle {" ++- " thickness = " ++ showShortFloat lw ++- ", radius = " ++ showShortFloat r ++- " }"-describePicture (Sector _ b e r) =- "sector {" ++- " startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++- showShortFloat b ++ " radians)" ++- ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++- showShortFloat e ++ " radians)" ++- ", radius = " ++ showShortFloat r ++- " }"-describePicture (Arc _ b e r) =- "arc {" ++- " startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++- showShortFloat b ++ " radians)" ++- ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "° (" ++- showShortFloat e ++ " radians)" ++- ", radius = " ++ showShortFloat r ++- " }"-describePicture (ThickArc _ b e r w) =- "thickArc {" ++- " startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++- showShortFloat b ++ " radians)" ++- ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++- showShortFloat e ++ " radians)" ++- ", radius = " ++ showShortFloat r ++- ", thickness = " ++ showShortFloat w ++- " }"-describePicture (Lettering _ txt) = printf "lettering { text = '%s' }" txt-describePicture (Blank _) = "blank"-describePicture (StyledLettering _ style font txt) =- printf " styledLettering { style = %s , font = %s, text = '%s' }"- (show style)- (show font)- txt-describePicture (Color _ (RGBA r g b a) _) =- "colored {" ++- " color = RGBA(" ++- showShortFloat r ++- ", " ++ showShortFloat g ++- ", " ++ showShortFloat b ++- ", " ++ showShortFloat a ++- ")" ++- " }"-describePicture (Translate _ x y _) =- "translated {" ++- " x = " ++ showShortFloat x ++- ", y = " ++ showShortFloat y ++- " }"-describePicture (Scale _ x y _) =- "scaled {" ++- " x = " ++ showShortFloat x ++- ", y = " ++ showShortFloat y ++- " }"-describePicture (Rotate _ angle _) =- "rotated { angle = " ++ showShortFloat angle ++ "° }"-describePicture (Dilate _ k _) =- "dilated { factor = " ++ showShortFloat k ++ " }"-describePicture (Logo _) = "codeWorldLogo"-describePicture (CoordinatePlane _) = "coordinatePlane"-describePicture (Pictures _) = "pictures"--setCallInfo :: Picture -> Object -> IO ()-setCallInfo pic obj = do- case getPictureSrcLoc pic of- Just loc -> do- setProp "name" (pToJSVal $ (trim 80 . describePicture) pic) obj- setProp "startLine" (pToJSVal $ srcLocStartLine loc) obj- setProp "startCol" (pToJSVal $ srcLocStartCol loc) obj- setProp "endLine" (pToJSVal $ srcLocEndLine loc) obj- setProp "endCol" (pToJSVal $ srcLocEndCol loc) obj- Nothing -> return ()--getPictureSrcLoc :: Picture -> Maybe SrcLoc-getPictureSrcLoc (SolidPolygon loc _) = Just loc-getPictureSrcLoc (SolidClosedCurve loc _) = Just loc-getPictureSrcLoc (Polygon loc _) = Just loc-getPictureSrcLoc (ThickPolygon loc _ _) = Just loc-getPictureSrcLoc (Rectangle loc _ _) = Just loc-getPictureSrcLoc (SolidRectangle loc _ _) = Just loc-getPictureSrcLoc (ThickRectangle loc _ _ _) = Just loc-getPictureSrcLoc (ClosedCurve loc _) = Just loc-getPictureSrcLoc (ThickClosedCurve loc _ _) = Just loc-getPictureSrcLoc (Circle loc _) = Just loc-getPictureSrcLoc (SolidCircle loc _) = Just loc-getPictureSrcLoc (ThickCircle loc _ _) = Just loc-getPictureSrcLoc (Polyline loc _) = Just loc-getPictureSrcLoc (ThickPolyline loc _ _) = Just loc-getPictureSrcLoc (Curve loc _) = Just loc-getPictureSrcLoc (ThickCurve loc _ _) = Just loc-getPictureSrcLoc (Sector loc _ _ _) = Just loc-getPictureSrcLoc (Arc loc _ _ _) = Just loc-getPictureSrcLoc (ThickArc loc _ _ _ _) = Just loc-getPictureSrcLoc (Lettering loc _) = Just loc-getPictureSrcLoc (Blank loc) = Just loc-getPictureSrcLoc (StyledLettering loc _ _ _) = Just loc-getPictureSrcLoc (Color loc _ _) = Just loc-getPictureSrcLoc (Translate loc _ _ _) = Just loc-getPictureSrcLoc (Scale loc _ _ _) = Just loc-getPictureSrcLoc (Dilate loc _ _) = Just loc-getPictureSrcLoc (Rotate loc _ _) = Just loc-getPictureSrcLoc (Logo loc) = Just loc-getPictureSrcLoc (CoordinatePlane loc) = Just loc-getPictureSrcLoc (Pictures _) = Nothing---- If a picture is found, the result will include an array of the base picture--- and all transformations.-findTopShapeFromPoint :: Point -> Drawing -> IO (Maybe NodeId)-findTopShapeFromPoint (x, y) pic = do- buf <- Canvas.create 500 500- ctx <- Canvas.getContext buf- (found, node) <- runCanvasM ctx $- findTopShape (translateDS (10 - x / 25) (y / 25 - 10) initialDS)- pic- case found of- True -> return $ Just node- False -> return Nothing--findTopShape :: DrawState -> Drawing -> CanvasM (Bool, Int)-findTopShape ds (Shape drawer) = do- contained <- shapeContains $ drawer ds- case contained of- True -> return (True, 0)- False -> return (False, 1)-findTopShape ds (Transformation f d) =- map2 (+ 1) $ findTopShape (f ds) d-findTopShape ds (Drawings []) = return (False, 1)-findTopShape ds (Drawings (dr:drs)) = do- (found, count) <- findTopShape ds dr- case found of- True -> return (True, count + 1)- False -> map2 (+ count) $ findTopShape ds (Drawings drs)--map2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)-map2 = fmap . fmap--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 = DrawState -> DrawMethods--data DrawMethods = DrawMethods- { drawShape :: CanvasM ()- , shapeContains :: CanvasM Bool- }--polygonDrawer ps smooth ds =- DrawMethods- { drawShape = do- trace- applyColor ds- CM.fill- , shapeContains = do- trace- CM.isPointInPath (0, 0)- }- where- trace = withDS ds $ followPath ps True smooth--pathDrawer ps w closed smooth ds =- DrawMethods- { drawShape = drawFigure ds w $ followPath ps closed smooth- , shapeContains =- do let width =- if w == 0- then 0.3- else w- drawFigure ds width $ followPath ps closed smooth- CM.isPointInStroke (0, 0)- }--sectorDrawer b e r ds =- DrawMethods- { drawShape = do- trace- applyColor ds- CM.fill- , shapeContains = do- trace- CM.isPointInPath (0, 0)- }- where- trace =- withDS ds $ do- CM.arc 0 0 (25 * abs r) b e (b > e)- CM.lineTo (0, 0)--arcDrawer b e r w ds =- DrawMethods- { drawShape =- drawFigure ds w $ CM.arc 0 0 (25 * abs r) b e (b > e)- , shapeContains =- do let width =- if w == 0- then 0.3- else w- CM.lineWidth (width * 25)- drawFigure ds width $- CM.arc 0 0 (25 * abs r) b e (b > e)- CM.isPointInStroke (0, 0)- }--textDrawer sty fnt txt ds =- DrawMethods- { drawShape =- withDS ds $ do- CM.scale 1 (-1)- applyColor ds- CM.font (fontString sty fnt)- CM.fillText txt (0, 0)- , shapeContains =- do CM.font (fontString sty fnt)- width <- CM.measureText txt- let height = 25 -- constant, defined in fontString- withDS ds $- CM.rect ((-0.5) * width) ((-0.5) * height) width height- CM.isPointInPath (0, 0)- }--logoDrawer ds =- DrawMethods- { drawShape =- withDS ds $ do- CM.scale 1 (-1)- drawCodeWorldLogo ds (-221) (-91) 442 182- , shapeContains =- withDS ds $ do- CM.rect (-221) (-91) 442 182- CM.isPointInPath (0, 0)- }--coordinatePlaneDrawer ds =- DrawMethods- { drawShape = drawDrawing ds coordinatePlaneDrawing- , shapeContains = fst <$> findTopShape ds coordinatePlaneDrawing- }--foreign import javascript unsafe "showCanvas()" js_showCanvas ::- IO ()--followPath :: [Point] -> Bool -> Bool -> CanvasM ()-followPath [] closed _ = return ()-followPath [p1] closed _ = return ()-followPath ((sx, sy):ps) closed False = do- CM.moveTo (25 * sx, 25 * sy)- forM_ ps $ \(x, y) -> CM.lineTo (25 * x, 25 * y)- when closed $ CM.closePath-followPath [p1, p2] False True = followPath [p1, p2] False False-followPath ps False True = do- let [(x1, y1), (x2, y2), (x3, y3)] = take 3 ps- dprev = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)- dnext = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)- p = dprev / (dprev + dnext)- cx = x2 + p * (x1 - x3) / 2- cy = y2 + p * (y1 - y3) / 2- CM.moveTo (25 * x1, 25 * y1)- CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x2, 25 * y2)- forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do- let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)- d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)- d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)- p = d1 / (d1 + d2)- r = d1 / (dp + d1)- cx1 = x2 + r * (x3 - x1) / 2- cy1 = y2 + r * (y3 - y1) / 2- cx2 = x3 + p * (x2 - x4) / 2- cy2 = y3 + p * (y2 - y4) / 2- CM.bezierCurveTo- (25 * cx1, 25 * cy1)- (25 * cx2, 25 * cy2)- (25 * x3, 25 * y3)- let [(x1, y1), (x2, y2), (x3, y3)] = reverse $ take 3 $ reverse ps- dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)- d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)- r = d1 / (dp + d1)- cx = x2 + r * (x3 - x1) / 2- cy = y2 + r * (y3 - y1) / 2- CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x3, 25 * y3)-followPath ps@(_:(sx, sy):_) True True = do- CM.moveTo (25 * sx, 25 * sy)- let rep = cycle ps- forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do- let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)- d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)- d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)- p = d1 / (d1 + d2)- r = d1 / (dp + d1)- cx1 = x2 + r * (x3 - x1) / 2- cy1 = y2 + r * (y3 - y1) / 2- cx2 = x3 + p * (x2 - x4) / 2- cy2 = y3 + p * (y2 - y4) / 2- CM.bezierCurveTo- (25 * cx1, 25 * cy1)- (25 * cx2, 25 * cy2)- (25 * x3, 25 * y3)- CM.closePath--drawFigure :: DrawState -> Double -> CanvasM () -> CanvasM ()-drawFigure ds w figure = do- withDS ds $ do- figure- when (w /= 0) $ do- CM.lineWidth (25 * w)- applyColor ds- CM.stroke- when (w == 0) $ do- CM.lineWidth 1- applyColor ds- CM.stroke--fontString :: TextStyle -> Font -> Text-fontString style font = stylePrefix style <> "25px " <> fontName font- where- stylePrefix Plain = ""- stylePrefix Bold = "bold "- stylePrefix Italic = "italic "- fontName SansSerif = "sans-serif"- fontName Serif = "serif"- fontName Monospace = "monospace"- fontName Handwriting = "cursive"- fontName Fancy = "fantasy"- fontName (NamedFont txt) =- "\"" <> T.filter (/= '"') txt <> "\""--drawDrawing :: DrawState -> Drawing -> CanvasM ()-drawDrawing ds (Shape shape) = drawShape $ shape ds-drawDrawing ds (Transformation f d) = drawDrawing (f ds) d-drawDrawing ds (Drawings drs) = mapM_ (drawDrawing ds) (reverse drs)--drawFrame :: Drawing -> CanvasM ()-drawFrame drawing = do- CM.fillColor 255 255 255 1- CM.fillRect (-250) (-250) 500 500- drawDrawing initialDS drawing--withScreen :: Element -> ClientRect.ClientRect -> CanvasM a -> IO a-withScreen canvas rect action = do- cw <- ClientRect.getWidth rect- ch <- ClientRect.getHeight rect- ctx <- js_getCodeWorldContext (canvasFromElement canvas)- runCanvasM ctx $ CM.saveRestore $ do- CM.translate (realToFrac cw / 2) (realToFrac ch / 2)- CM.scale (realToFrac cw / 500) (-realToFrac ch / 500)- CM.lineWidth 0- CM.textCenter- CM.textMiddle- action--setCanvasSize :: Element -> Element -> IO ()-setCanvasSize target canvas = do- rect <- getBoundingClientRect canvas- cx <- ClientRect.getWidth rect- cy <- ClientRect.getHeight rect- setAttribute target ("width" :: JSString) (show (round cx))- setAttribute target ("height" :: JSString) (show (round cy))--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 =- 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 }- | SteplessToken { tokenDeployHash :: Text- , tokenNumPlayers :: Int- , tokenInitial :: StaticKey- , tokenEvent :: StaticKey- , tokenDraw :: StaticKey }- | PartialToken { tokenDeployHash :: Text }- | NoToken- deriving (Generic)--deriving instance Generic Fingerprint--instance Serialize Fingerprint--instance Serialize GameToken------------------------------------------------------------------------------------ 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"- _ -> error "Unrecognized protocol"- return url--connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket-connectToGameServer handleServerMessage = do- let handleWSRequest m = do- maybeSM <- decodeServerMessage m- case maybeSM of- Nothing -> return ()- Just sm -> handleServerMessage sm- wsURL <- getWebSocketURL- let req =- WS.WebSocketRequest- { url = wsURL- , protocols = []- , onClose = Just $ \_ -> handleServerMessage GameAborted- , onMessage = Just handleWSRequest- }- WS.connect req- where- decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)- decodeServerMessage m =- case WS.getData m of- WS.StringData str -> do- return $ readMaybe (Data.JSString.unpack str)- _ -> return Nothing- encodeClientMessage :: ClientMessage -> JSString- encodeClientMessage m = Data.JSString.pack (show m)--sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()-sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws- where- encodeClientMessage :: ClientMessage -> JSString- encodeClientMessage m = Data.JSString.pack (show m)--initialGameState :: GameState s-initialGameState = Main CUI.initial--foreign import javascript- "/[&?]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- let fullStepHandler dt = stepHandler dt . eventHandler (-1) (TimePassing dt)- 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- fullStepHandler- eventHandler- token- currentGameState- screen <- js_getCodeWorldContext (canvasFromElement canvas)- let go t0 lastFrame = do- gs <- readMVar currentGameState- let pic = gameDraw fullStepHandler drawHandler gs t0- picFrame <- makeStableName $! pic- when (picFrame /= lastFrame) $ do- rect <- getBoundingClientRect canvas- withScreen (elementFromCanvas offscreenCanvas) rect $- drawFrame (pictureToDrawing pic)- rect <- getBoundingClientRect canvas- cw <- ClientRect.getWidth rect- ch <- ClientRect.getHeight rect- js_canvasDrawImage- screen- (elementFromCanvas offscreenCanvas)- 0- 0- (round cw)- (round ch)- t1 <- nextFrame- modifyMVar_ currentGameState $ return . gameStep fullStepHandler t1- go t1 picFrame- t0 <- getTime- nullFrame <- makeStableName undefined- initialStateName <- makeStableName $! initialGameState- go t0 nullFrame--run :: s- -> (Double -> s -> s)- -> (e -> s -> s)- -> (s -> Drawing)- -> (Double -> e)- -> IO (e -> IO (), IO s)-run initial stepHandler eventHandler drawHandler injectTime = do- let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt)- 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- needsRedraw <- newMVar ()- on window resize $ void $ liftIO $ do- setCanvasSize canvas canvas- setCanvasSize (elementFromCanvas offscreenCanvas) canvas- tryPutMVar needsRedraw ()- 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- withScreen (elementFromCanvas offscreenCanvas) rect $- drawFrame pic- 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 . fullStepHandler 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 fullStepHandler nextState- nextFrame <- tryTakeMVar needsRedraw >>= \case- Nothing -> return picFrame- Just () -> makeStableName undefined- go t1 nextFrame nextStateName nextNeedsTime- t0 <- getTime- nullFrame <- makeStableName undefined- initialStateName <- makeStableName $! initial- 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 = withoutPreemption $ do- drawing <- draw- rect <- getBoundingClientRect canvas- withScreen (elementFromCanvas offscreenCanvas) rect $- drawFrame drawing- 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---- Utility functions that apply a function in either the left or right half of a--- tuple. Crucially, if the function preserves sharing on its side, then the--- wrapper also preserves sharing.-inLeft :: (a -> a) -> (a, b) -> (a, b)-inLeft f ab = unsafePerformIO $ do- let (a, b) = ab- aName <- makeStableName $! a- let a' = f a- aName' <- makeStableName $! a'- return $ if aName == aName' then ab else (a', b)--inRight :: (b -> b) -> (a, b) -> (a, b)-inRight f ab = unsafePerformIO $ do- let (a, b) = ab- bName <- makeStableName $! b- let b' = f b- bName' <- makeStableName $! b'- return $ if bName == bName' then ab else (a, b')---- Wraps the event and state from run so they can be paused by pressing the Inspect--- button.-runInspect :: - (Wrapped s -> [Control s])- -> s- -> (Double -> s -> s)- -> (Event -> s -> s)- -> (s -> Picture) - -> IO ()-runInspect controls initial stepHandler eventHandler drawHandler = do- Just window <- currentWindow- Just doc <- currentDocument- Just canvas <- getElementById doc ("screen" :: JSString)- let initialWrapper = (debugStateInit, wrappedInitial initial)- stepHandlerWrapper dt wrapper@(debugState, _) =- case debugStateActive debugState of- True -> wrapper- False -> inRight (wrappedStep stepHandler dt) wrapper- eventHandlerWrapper evt wrapper@(debugState, _) =- case (debugStateActive debugState, evt) of- (_, Left debugEvent) ->- inLeft (updateDebugState debugEvent) wrapper- (True, _) -> wrapper- (_, Right normalEvent) ->- inRight (wrappedEvent controls stepHandler eventHandler normalEvent) wrapper- drawHandlerWrapper (debugState, wrappedState) =- case debugStateActive debugState of- True -> drawDebugState debugState $ pictureToDrawing $ drawHandler (state wrappedState)- False -> pictureToDrawing (wrappedDraw controls drawHandler wrappedState)- drawPicHandler (debugState, wrappedState) =- drawHandler $ state wrappedState- (sendEvent, getState) <-- run- initialWrapper- stepHandlerWrapper- eventHandlerWrapper- drawHandlerWrapper- (Right . TimePassing)- let pauseEvent True = sendEvent $ Left DebugStart- pauseEvent False = sendEvent $ Left DebugStop- highlightSelectEvent True n = sendEvent $ Left (HighlightEvent n)- highlightSelectEvent False n = sendEvent $ Left (SelectEvent n)- onEvents canvas (sendEvent . Right)- inspect (drawPicHandler <$> getState) pauseEvent highlightSelectEvent---- 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 fullStepHandler dt = stepHandler dt . eventHandler (TimePassing dt)- let rect = (Canvas.width context, Canvas.height context)- offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect- currentState <- newMVar initial- eventHappened <- newMVar ()- onEvents context rect $ \event -> do- modifyMVar_ currentState (return . eventHandler event)- tryPutMVar eventHappened ()- return ()- let go t0 lastFrame lastStateName needsTime = do- pic <- drawHandler <$> readMVar currentState- picFrame <- makeStableName $! pic- when (picFrame /= lastFrame) $- Canvas.send context $ do- Canvas.with offscreenCanvas $- Canvas.saveRestore $ do- setupScreenContext rect- drawDrawing initialDS (pictureToDrawing pic)- Canvas.drawImageAt (offscreenCanvas, 0, 0)- t1 <-- if | needsTime ->- do tn <- getCurrentTime- threadDelay $- max- 0- (50000 -- round ((tn `diffUTCTime` t0) * 1000000))- t1 <- getCurrentTime- let dt = realToFrac (t1 `diffUTCTime` t0)- modifyMVar_ currentState (return . fullStepHandler dt)- return t1- | otherwise ->- do takeMVar eventHappened- getCurrentTime- nextState <- readMVar currentState- nextStateName <- makeStableName $! nextState- nextNeedsTime <-- if nextStateName == lastStateName- then not <$> isUniversallyConstant fullStepHandler nextState- else return True- go t1 picFrame nextStateName nextNeedsTime- t0 <- getCurrentTime- nullFrame <- makeStableName undefined- initialStateName <- makeStableName $! initial- go t0 nullFrame initialStateName True--runInspect :: - (Wrapped s -> [Control s])- -> s- -> (Double -> s -> s)- -> (Event -> s -> s)- -> (s -> Picture) - -> IO ()-runInspect controls initial stepHandler eventHandler drawHandler =- run (wrappedInitial initial)- (wrappedStep stepHandler)- (wrappedEvent controls stepHandler eventHandler)- (wrappedDraw controls drawHandler)--getDeployHash :: IO Text-getDeployHash = error "game API unimplemented in stand-alone interface mode"--runGame ::- GameToken- -> Int- -> (StdGen -> s)- -> (Double -> s -> s)- -> (Int -> Event -> s -> s)- -> (Int -> s -> Picture)- -> IO ()-runGame = error "game API unimplemented in stand-alone interface mode"-#endif------------------------------------------------------------------------------------- Common code for game interface--groupActivityOf numPlayers initial event draw = do- dhash <- getDeployHash- let token =- SteplessToken- { tokenDeployHash = dhash- , tokenNumPlayers = numPlayers- , tokenInitial = staticKey initial- , tokenEvent = staticKey event- , tokenDraw = staticKey draw- }- runGame- token- numPlayers- (deRefStaticPtr initial)- (const id)- (deRefStaticPtr event)- (deRefStaticPtr draw)--unsafeGroupActivityOf numPlayers initial event draw =- unsafeCollaborationOf numPlayers initial (const id) event draw--unsafeCollaborationOf numPlayers initial step event draw = do- dhash <- getDeployHash- let token = PartialToken dhash- runGame token numPlayers initial step event draw- where- token = NoToken--collaborationOf numPlayers initial step event draw = do- dhash <- getDeployHash- let token =- FullToken- { tokenDeployHash = dhash- , tokenNumPlayers = numPlayers- , tokenInitial = staticKey initial- , tokenStep = staticKey step- , tokenEvent = staticKey event- , tokenDraw = staticKey draw- }- runGame- token- numPlayers- (deRefStaticPtr initial)- (deRefStaticPtr step)- (deRefStaticPtr event)- (deRefStaticPtr draw)------------------------------------------------------------------------------------- Common code for activity, interaction, animation and simulation interfaces--activityOf initial change picture =- interactionOf initial (const id) change picture--interactionOf = runInspect (const [])--data Wrapped a = Wrapped- { state :: a- , playbackSpeed :: Double- , lastInteractionTime :: Double- , isDragging :: Bool- } deriving (Show, Functor)--data Control :: * -> * where- PlayButton :: Control a- PauseButton :: Control a- StepButton :: Control a- RestartButton :: Control Double- BackButton :: Control Double- TimeLabel :: Control Double- SpeedSlider :: Control a- UndoButton :: Control [a]--wrappedInitial :: a -> Wrapped a-wrappedInitial w = Wrapped { - state = w,- playbackSpeed = 1,- lastInteractionTime = 1000,- isDragging = False- }--wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a-wrappedStep f dt w =- w- { state =- if playbackSpeed w == 0- then state w- else f (dt * playbackSpeed w) (state w)- , lastInteractionTime = lastInteractionTime w + dt- }--wrappedEvent :: forall a . - (Wrapped a -> [Control a])- -> (Double -> a -> a)- -> (Event -> a -> a)- -> Event- -> Wrapped a- -> Wrapped a-wrappedEvent _ _ eventHandler (TimePassing dt) w- | playbackSpeed w == 0 = w- | otherwise = fmap (eventHandler (TimePassing dt)) w-wrappedEvent ctrls f eventHandler event w- | playbackSpeed w == 0 || handled = afterControls {lastInteractionTime = 0}- | otherwise = fmap (eventHandler event) afterControls {lastInteractionTime = 0}- where - afterControls :: Wrapped a- handled :: Bool- (afterControls, handled) = foldr stepFunction (w, False) (ctrls w)- stepFunction :: Control a -> (Wrapped a, Bool) -> (Wrapped a, Bool)- stepFunction control (world, handled)- | handled == True = (world, True)- | otherwise = handleControl f event control world--xToPlaybackSpeed :: Double -> Double-xToPlaybackSpeed x = foldr (snapSlider) (min 5 $ max 0 $ 5 * (x + 4.4) / 2.8) [1..4]--snapSlider :: Double -> Double -> Double-snapSlider target val | abs (val - target) < 0.2 = target- | otherwise = val--handleControl ::- (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool)-handleControl _ (PointerPress (x, y)) RestartButton w- | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6 = (w {state = 0}, True)-handleControl _ (PointerPress (x, y)) PlayButton w- | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = (w {playbackSpeed = 1}, True) -handleControl _ (PointerPress (x, y)) PauseButton w- | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = (w {playbackSpeed = 0}, True)-handleControl _ (PointerPress (x,y)) BackButton w- | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 =- (w {state = max 0 (state w - 0.1)}, True)-handleControl _ (PointerPress (x,y)) UndoButton w- | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 =- (w {state = tail (state w)}, True)-handleControl f (PointerPress (x, y)) StepButton w- | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6 = (w {state = f 0.1 (state w)}, True)-handleControl _ (PointerPress (x, y)) SpeedSlider w- | -4.5 < x && x < -1.5 && -9.4 < y && y < -8.6 = - (w {playbackSpeed = xToPlaybackSpeed x, isDragging = True}, True)-handleControl _ (PointerMovement (x, y)) SpeedSlider w- | isDragging w = (w {playbackSpeed = xToPlaybackSpeed x}, True)-handleControl _ (PointerRelease (x, y)) SpeedSlider w- | isDragging w = (w {playbackSpeed = xToPlaybackSpeed x, isDragging = False}, True)-handleControl _ _ _ w = (w, False)--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- | lastInteractionTime w < 4.5 = 1- | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w- | otherwise = 0--drawControl :: Wrapped a -> Double -> Control a -> Picture-drawControl _ alpha RestartButton = 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 UndoButton = 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)-drawControl w alpha SpeedSlider = translated (-3) (-9) p- where- p =- colored- (RGBA 0 0 0 alpha)- (translated x 0.75 $ scaled 0.5 0.5 $ lettering (pack (showFFloatAlt (Just 2) (playbackSpeed w) ""))) <>- translated x 0 (solidRectangle 0.2 0.8) <>- colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.25) <>- colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.25)- x = playbackSpeed w / 5 * 2.8 - 1.4--animationControls :: Wrapped Double -> [Control Double]-animationControls w- | lastInteractionTime w > 5 = []- | playbackSpeed w == 0 && state w > 0 =- [RestartButton, PlayButton, StepButton, BackButton, TimeLabel, SpeedSlider]- | playbackSpeed w == 0 = [RestartButton, PlayButton, StepButton, TimeLabel, SpeedSlider]- | otherwise = [RestartButton, PauseButton, TimeLabel, SpeedSlider]--animationOf f = runInspect animationControls 0 (+) (\_ r -> r) f--simulationControls :: Wrapped w -> [Control w]-simulationControls w- | lastInteractionTime w > 5 = []- | playbackSpeed w == 0 = [PlayButton, StepButton, SpeedSlider]- | otherwise = [PauseButton, SpeedSlider]--statefulDebugControls :: Wrapped [w] -> [Control [w]]-statefulDebugControls w- | lastInteractionTime w > 5 = []- | playbackSpeed w == 0 && not (null (tail (state w))) = [PlayButton, StepButton, SpeedSlider, UndoButton]- | playbackSpeed w == 0 = [PlayButton, StepButton, SpeedSlider]- | otherwise = [PauseButton, SpeedSlider]--simulationOf initial step draw =- runInspect simulationControls initial step (\_ r -> r) draw--prependIfChanged :: (a -> a) -> [a] -> [a]-prependIfChanged f (x:xs) = case x `seq` x' `seq` (reallyUnsafePtrEquality# x x') of- 0# -> x' : x : xs- _ -> x : xs- where x' = f x--debugSimulationOf initial simStep simDraw =- runInspect statefulDebugControls [initial] step (\_ r -> r) draw- where- step dt = prependIfChanged (simStep dt)- draw (x:xs) = simDraw x--debugInteractionOf initial baseStep baseEvent baseDraw = - runInspect statefulDebugControls [initial] step event draw - where- step dt = prependIfChanged (baseStep dt)- event e = prependIfChanged (baseEvent e)- draw (x:xs) = baseDraw x+ Copyright 2019 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}+module CodeWorld.Driver+ ( drawingOf+ , animationOf+ , activityOf+ , debugActivityOf+ , groupActivityOf+ , unsafeGroupActivityOf+ , simulationOf+ , debugSimulationOf+ , interactionOf+ , debugInteractionOf+ , collaborationOf+ , unsafeCollaborationOf+ , trace+ ) where++import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState)+import qualified CodeWorld.CollaborationUI as CUI+import qualified CodeWorld.CanvasM as CM+import CodeWorld.CanvasM (CanvasM, runCanvasM)+import CodeWorld.Color+import CodeWorld.Event+import CodeWorld.Picture+import Control.Concurrent+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Control.Monad.Trans (liftIO)+import Data.Char (chr)+import Data.List (find, zip4, intercalate)+import Data.Maybe (fromMaybe, isNothing, mapMaybe)+import Data.Monoid+import Data.Serialize+import Data.Serialize.Text+import qualified Data.Text as T+import Data.Text (Text, pack, singleton)+import qualified Debug.Trace+import GHC.Fingerprint.Type+import GHC.Generics+import GHC.Prim+import GHC.Stack+import GHC.StaticPtr+import Numeric (showFFloatAlt)+import System.Environment+import System.IO+import System.IO.Unsafe+import System.Mem.StableName+import System.Random+import Text.Printf+import Text.Read++#ifdef ghcjs_HOST_OS++import CodeWorld.Message+import CodeWorld.Prediction+import qualified Control.Monad.Trans.State as State+import Data.Hashable+import Data.IORef+import qualified Data.JSString+import Data.JSString.Text+import Data.Word+import GHCJS.Concurrent (withoutPreemption)+import GHCJS.DOM+import qualified GHCJS.DOM.ClientRect as ClientRect+import GHCJS.DOM.Document+import GHCJS.DOM.Element+import GHCJS.DOM.EventM+import GHCJS.DOM.GlobalEventHandlers hiding (error)+import GHCJS.DOM.MouseEvent+import GHCJS.DOM.NonElementParentNode+import GHCJS.DOM.Types (Element, unElement)+import qualified GHCJS.DOM.Window as Window+import GHCJS.Foreign+import GHCJS.Foreign.Callback+import GHCJS.Marshal+import GHCJS.Marshal.Pure+import GHCJS.Types+import qualified JavaScript.Array as Array+import JavaScript.Object+import JavaScript.Web.AnimationFrame+import qualified JavaScript.Web.Canvas as Canvas+import qualified JavaScript.Web.Canvas.Internal as Canvas+import qualified JavaScript.Web.Location as Loc+import qualified JavaScript.Web.MessageEvent as WS+import qualified JavaScript.Web.WebSocket as WS+import Unsafe.Coerce++#else++import Data.Time.Clock+import qualified Graphics.Blank as Canvas+import Graphics.Blank (Canvas)+import Text.Printf++#endif++--------------------------------------------------------------------------------+-- The common interface, provided by both implementations below.+-- | Draws a 'Picture'. This is the simplest CodeWorld entry point.+drawingOf :: Picture -- ^ The picture to show on the screen.+ -> IO ()++-- | Shows an animation, with a picture for each time given by the parameter.+animationOf :: (Double -> Picture) -- ^ A function that produces animation+ -- frames, given the time in seconds.+ -> IO ()++-- | Runs an interactive CodeWorld program that responds to events. Activities+-- can interact with the user, change over time, and remember information about+-- the past.+activityOf+ :: world -- ^ The initial state of the interaction.+ -> (Event -> world -> world) -- ^ The event handling function, which updates+ -- the state given an event.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++-- | Runs an interactive CodeWorld program in debugging mode. In this mode,+-- the program gets controls to pause and manipulate time, and even go back in+-- time to look at past states.+debugActivityOf+ :: world -- ^ The initial state of the interaction.+ -> (Event -> world -> world) -- ^ The event handling function, which updates+ -- the state given an event.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++-- | Runs an interactive multi-user CodeWorld program that is joined by several+-- participants over the internet.+groupActivityOf+ :: Int -- ^ The number of participants to expect. The participants will be+ -- ^ numbered starting at 0.+ -> StaticPtr (StdGen -> world)+ -- ^ The initial state of the activity.+ -> StaticPtr (Int -> Event -> world -> world)+ -- ^ The event handling function, which updates the state given a+ -- participant number and user interface event.+ -> StaticPtr (Int -> world -> Picture)+ -- ^ The visualization function, which converts a participant number+ -- and the state into a picture to display.+ -> IO ()++-- | A version of 'groupActivityOf' that avoids static pointers, and does not+-- check for consistency.+unsafeGroupActivityOf+ :: Int -- ^ The number of participants to expect. The participants will be+ -- ^ numbered starting at 0.+ -> (StdGen -> world)+ -- ^ The initial state of the activity.+ -> (Int -> Event -> world -> world)+ -- ^ The event handling function, which updates the state given a+ -- participant number and user interface event.+ -> (Int -> world -> Picture)+ -- ^ The visualization function, which converts a participant number+ -- and the state into a picture to display.+ -> IO ()++-- | Shows a simulation, which is essentially a continuous-time dynamical+-- system described by an initial value and step function.+simulationOf+ :: world -- ^ The initial state of the simulation.+ -> (Double -> world -> world) -- ^ The time step function, which advances+ -- the state given the time difference.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++debugSimulationOf+ :: world -- ^ The initial state of the simulation.+ -> (Double -> world -> world) -- ^ The time step function, which advances+ -- the state given the time difference.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++-- | Runs an interactive event-driven CodeWorld program. This is a+-- generalization of simulations that can respond to events like key presses+-- and mouse movement.+interactionOf+ :: world -- ^ The initial state of the interaction.+ -> (Double -> world -> world) -- ^ The time step function, which advances+ -- the state given the time difference.+ -> (Event -> world -> world) -- ^ The event handling function, which updates+ -- the state given a user interface event.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++debugInteractionOf+ :: world -- ^ The initial state of the interaction.+ -> (Double -> world -> world) -- ^ The time step function, which advances+ -- the state given the time difference.+ -> (Event -> world -> world) -- ^ The event handling function, which updates+ -- the state given a user interface event.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++-- | Runs an interactive multi-user CodeWorld program, involving multiple+-- participants over the internet.+collaborationOf+ :: Int -- ^ The number of participants to expect. The participants will be+ -- ^ numbered starting at 0.+ -> StaticPtr (StdGen -> world)+ -- ^ The initial state of the collaboration.+ -> StaticPtr (Double -> world -> world)+ -- ^ The time step function, which advances the state given the time+ -- difference.+ -> StaticPtr (Int -> Event -> world -> world)+ -- ^ The event handling function, which updates the state given a+ -- participant number and user interface event.+ -> StaticPtr (Int -> world -> Picture)+ -- ^ The visualization function, which converts a participant number+ -- and the state into a picture to display.+ -> IO ()++-- | A version of 'collaborationOf' that avoids static pointers, and does not+-- check for consistent parameters.+unsafeCollaborationOf+ :: Int -- ^ The number of participants to expect. The participants will be+ -- ^ numbered starting at 0.+ -> (StdGen -> world)+ -- ^ The initial state of the collaboration.+ -> (Double -> world -> world)+ -- ^ The time step function, which advances the state given the time+ -- difference.+ -> (Int -> Event -> world -> world)+ -- ^ The event handling function, which updates the state given a+ -- participant number and user interface event.+ -> (Int -> world -> Picture)+ -- ^ The visualization function, which converts a participant number+ -- and the state into a picture to display.+ -> IO ()++-- | Prints a debug message to the CodeWorld console when a value is forced.+-- This is equivalent to the similarly named function in `Debug.Trace`, except+-- that it uses the CodeWorld console instead of standard output.+trace :: Text -> a -> a++--------------------------------------------------------------------------------+-- A Drawing is an intermediate and simpler representation of a Picture, suitable+-- for drawing. A drawing does not contain unnecessary metadata like CallStacks.+-- The drawer is specific to the platform.+data Drawing+ = Shape Drawer+ | Transformation (DrawState -> DrawState)+ Drawing+ | Drawings [Drawing]++#if MIN_VERSION_base(4,11,0)++instance Semigroup Drawing where+ a <> Drawings bs = Drawings (a : bs)+ a <> b = Drawings [a, b]++#endif++instance Monoid Drawing where+ mempty = Drawings []+ mappend a (Drawings bs) = Drawings (a : bs)+ mappend a b = Drawings [a, b]+ mconcat = Drawings++-- A DrawState is an affine transformation matrix, plus a Bool indicating whether+-- a color has been chosen yet.+type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color)++-- A NodeId a unique id for each node in a Picture of Drawing, chosen by the order+-- the node appears in DFS. When a Picture is converted to a drawing the NodeId's of+-- corresponding nodes are shared. Always >=0.+type NodeId = Int++pictureToDrawing :: Picture -> Drawing+pictureToDrawing (SolidClosedCurve _ pts) = Shape $ polygonDrawer pts True+pictureToDrawing (SolidPolygon _ pts) = Shape $ polygonDrawer pts False+pictureToDrawing (Polygon _ pts) = Shape $ pathDrawer pts 0 True False+pictureToDrawing (ThickPolygon _ pts w) = Shape $ pathDrawer pts w True False+pictureToDrawing (Rectangle _ w h) = Shape $ pathDrawer (rectangleVertices w h) 0 True False+pictureToDrawing (SolidRectangle _ w h) = Shape $ polygonDrawer (rectangleVertices w h) False+pictureToDrawing (ThickRectangle _ lw w h) = Shape $ pathDrawer (rectangleVertices w h) lw True False+pictureToDrawing (ClosedCurve _ pts) = Shape $ pathDrawer pts 0 True True+pictureToDrawing (ThickClosedCurve _ pts w) = Shape $ pathDrawer pts w True True+pictureToDrawing (Circle _ r) = Shape $ arcDrawer 0 (2 * pi) r 0+pictureToDrawing (SolidCircle _ r) = Shape $ sectorDrawer 0 (2 * pi) r +pictureToDrawing (ThickCircle _ lw r) = Shape $ arcDrawer 0 (2 * pi) r lw+pictureToDrawing (Polyline _ pts) = Shape $ pathDrawer pts 0 False False+pictureToDrawing (ThickPolyline _ pts w) = Shape $ pathDrawer pts w False False+pictureToDrawing (Curve _ pts) = Shape $ pathDrawer pts 0 False True+pictureToDrawing (ThickCurve _ pts w) = Shape $ pathDrawer pts w False True+pictureToDrawing (Sector _ b e r) = Shape $ sectorDrawer b e r+pictureToDrawing (Arc _ b e r) = Shape $ arcDrawer b e r 0+pictureToDrawing (ThickArc _ b e r w) = Shape $ arcDrawer b e r w+pictureToDrawing (Lettering _ txt) = Shape $ textDrawer Plain Serif txt+pictureToDrawing (Blank _) = Drawings $ []+pictureToDrawing (StyledLettering _ sty fnt txt) = Shape $ textDrawer sty fnt txt+pictureToDrawing (Logo _) = Shape $ logoDrawer+pictureToDrawing (CoordinatePlane _) = Shape $ coordinatePlaneDrawer+pictureToDrawing (Color _ col p) =+ Transformation (setColorDS col) $ pictureToDrawing p+pictureToDrawing (Translate _ x y p) =+ Transformation (translateDS x y) $ pictureToDrawing p+pictureToDrawing (Scale _ x y p) =+ Transformation (scaleDS x y) $ pictureToDrawing p+pictureToDrawing (Dilate _ k p) =+ Transformation (scaleDS k k) $ pictureToDrawing p+pictureToDrawing (Rotate _ r p) =+ Transformation (rotateDS r) $ pictureToDrawing p+pictureToDrawing (Pictures _ ps) = Drawings $ pictureToDrawing <$> ps+pictureToDrawing (PictureAnd _ ps) = Drawings $ pictureToDrawing <$> ps++initialDS :: DrawState+initialDS = (1, 0, 0, 1, 0, 0, Nothing)++translateDS :: Double -> Double -> DrawState -> DrawState+translateDS x y (a, b, c, d, e, f, hc) =+ (a, b, c, d, a * 25 * x + c * 25 * y + e, b * 25 * x + d * 25 * y + f, hc)++scaleDS :: Double -> Double -> DrawState -> DrawState+scaleDS x y (a, b, c, d, e, f, hc) = (x * a, x * b, y * c, y * d, e, f, hc)++rotateDS :: Double -> DrawState -> DrawState+rotateDS r (a, b, c, d, e, f, hc) =+ ( a * cos r + c * sin r+ , b * cos r + d * sin r+ , c * cos r - a * sin r+ , d * cos r - b * sin r+ , e+ , f+ , hc)++setColorDS :: Color -> DrawState -> DrawState+setColorDS col (a, b, c, d, e, f, Nothing) = (a, b, c, d, e, f, Just col)+setColorDS col@(RGBA _ _ _ 0) (a, b, c, d, e, f, _) =+ (a, b, c, d, e, f, Just col)+setColorDS (RGBA _ _ _ alpha1) (a, b, c, d, e, f, Just (RGBA rr gg bb alpha2)) =+ (a, b, c, d, e, f, Just (RGBA rr gg bb (alpha1 * alpha2)))++getColorDS :: DrawState -> Maybe Color+getColorDS (a, b, c, d, e, f, col) = col++polygonDrawer :: [Point] -> Bool -> Drawer+pathDrawer :: [Point] -> Double -> Bool -> Bool -> Drawer+sectorDrawer :: Double -> Double -> Double -> Drawer+arcDrawer :: Double -> Double -> Double -> Double -> Drawer+textDrawer :: TextStyle -> Font -> Text -> Drawer+logoDrawer :: Drawer+coordinatePlaneDrawer :: Drawer+coordinatePlaneDrawing :: Drawing+coordinatePlaneDrawing = pictureToDrawing $ axes <> numbers <> guidelines+ where+ xline y = thickPolyline 0.01 [(-10, y), (10, y)]+ xaxis = thickPolyline 0.03 [(-10, 0), (10, 0)]+ axes = xaxis <> rotated (pi / 2) xaxis+ xguidelines = pictures [xline k | k <- [-10,-9 .. 10]]+ guidelines = xguidelines <> rotated (pi / 2) xguidelines+ numbers = xnumbers <> ynumbers+ xnumbers =+ pictures+ [ translated+ (fromIntegral k)+ 0.3+ (scaled 0.5 0.5 (lettering (pack (show k))))+ | k <- [-9,-8 .. 9]+ , k /= 0+ ]+ ynumbers =+ pictures+ [ translated+ 0.3+ (fromIntegral k)+ (scaled 0.5 0.5 (lettering (pack (show k))))+ | k <- [-9,-8 .. 9]+ , k /= 0+ ]++withDS :: DrawState -> CanvasM a -> CanvasM a+withDS (ta, tb, tc, td, te, tf, col) action = CM.saveRestore $ do+ CM.transform ta tb tc td te tf+ CM.beginPath+ action++applyColor :: DrawState -> CanvasM ()+applyColor ds =+ case getColorDS ds of+ Nothing -> do+ CM.strokeColor 0 0 0 1+ CM.fillColor 0 0 0 1+ Just (RGBA r g b a) -> do+ CM.strokeColor+ (round $ r * 255)+ (round $ g * 255)+ (round $ b * 255)+ a+ CM.fillColor+ (round $ r * 255)+ (round $ g * 255)+ (round $ b * 255)+ a++type Drawer = DrawState -> DrawMethods++data DrawMethods = DrawMethods+ { drawShape :: CanvasM ()+ , shapeContains :: CanvasM Bool+ }++polygonDrawer ps smooth ds =+ DrawMethods+ { drawShape = do+ trace+ applyColor ds+ CM.fill+ , shapeContains = do+ trace+ CM.isPointInPath (0, 0)+ }+ where+ trace = withDS ds $ followPath ps True smooth++pathDrawer ps w closed smooth ds =+ DrawMethods+ { drawShape = drawFigure ds w $ followPath ps closed smooth+ , shapeContains =+ do let width =+ if w == 0+ then 0.3+ else w+ drawFigure ds width $ followPath ps closed smooth+ CM.isPointInStroke (0, 0)+ }++sectorDrawer b e r ds =+ DrawMethods+ { drawShape = do+ trace+ applyColor ds+ CM.fill+ , shapeContains = do+ trace+ CM.isPointInPath (0, 0)+ }+ where+ trace =+ withDS ds $ do+ CM.arc 0 0 (25 * abs r) b e (b > e)+ CM.lineTo (0, 0)++arcDrawer b e r w ds =+ DrawMethods+ { drawShape =+ drawFigure ds w $ CM.arc 0 0 (25 * abs r) b e (b > e)+ , shapeContains =+ do let width =+ if w == 0+ then 0.3+ else w+ CM.lineWidth (width * 25)+ drawFigure ds width $+ CM.arc 0 0 (25 * abs r) b e (b > e)+ CM.isPointInStroke (0, 0)+ }++textDrawer sty fnt txt ds =+ DrawMethods+ { drawShape =+ withDS ds $ do+ CM.scale 1 (-1)+ applyColor ds+ CM.font (fontString sty fnt)+ CM.fillText txt (0, 0)+ , shapeContains =+ do CM.font (fontString sty fnt)+ width <- CM.measureText txt+ let height = 25 -- constant, defined in fontString+ withDS ds $+ CM.rect ((-0.5) * width) ((-0.5) * height) width height+ CM.isPointInPath (0, 0)+ }++logoDrawer ds =+ DrawMethods+ { drawShape =+ withDS ds $ do+ CM.scale 1 (-1)+ drawCodeWorldLogo ds (-221) (-91) 442 182+ , shapeContains =+ withDS ds $ do+ CM.rect (-221) (-91) 442 182+ CM.isPointInPath (0, 0)+ }++coordinatePlaneDrawer ds =+ DrawMethods+ { drawShape = drawDrawing ds coordinatePlaneDrawing+ , shapeContains = fst <$> findTopShape ds coordinatePlaneDrawing+ }++followPath :: [Point] -> Bool -> Bool -> CanvasM ()+followPath [] closed _ = return ()+followPath [p1] closed _ = return ()+followPath ((sx, sy):ps) closed False = do+ CM.moveTo (25 * sx, 25 * sy)+ forM_ ps $ \(x, y) -> CM.lineTo (25 * x, 25 * y)+ when closed $ CM.closePath+followPath [p1, p2] False True = followPath [p1, p2] False False+followPath ps False True = do+ let [(x1, y1), (x2, y2), (x3, y3)] = take 3 ps+ dprev = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+ dnext = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+ p = dprev / (dprev + dnext)+ cx = x2 + p * (x1 - x3) / 2+ cy = y2 + p * (y1 - y3) / 2+ CM.moveTo (25 * x1, 25 * y1)+ CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x2, 25 * y2)+ forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do+ let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+ d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+ d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ CM.bezierCurveTo+ (25 * cx1, 25 * cy1)+ (25 * cx2, 25 * cy2)+ (25 * x3, 25 * y3)+ let [(x1, y1), (x2, y2), (x3, y3)] = reverse $ take 3 $ reverse ps+ dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+ d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+ r = d1 / (dp + d1)+ cx = x2 + r * (x3 - x1) / 2+ cy = y2 + r * (y3 - y1) / 2+ CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x3, 25 * y3)+followPath ps@(_:(sx, sy):_) True True = do+ CM.moveTo (25 * sx, 25 * sy)+ let rep = cycle ps+ forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do+ let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2)+ d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2)+ d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ CM.bezierCurveTo+ (25 * cx1, 25 * cy1)+ (25 * cx2, 25 * cy2)+ (25 * x3, 25 * y3)+ CM.closePath++drawFigure :: DrawState -> Double -> CanvasM () -> CanvasM ()+drawFigure ds w figure = do+ withDS ds $ do+ figure+ when (w /= 0) $ do+ CM.lineWidth (25 * w)+ applyColor ds+ CM.stroke+ when (w == 0) $ do+ CM.lineWidth 1+ applyColor ds+ CM.stroke++fontString :: TextStyle -> Font -> Text+fontString style font = stylePrefix style <> "25px " <> fontName font+ where+ stylePrefix Plain = ""+ stylePrefix Bold = "bold "+ stylePrefix Italic = "italic "+ fontName SansSerif = "sans-serif"+ fontName Serif = "serif"+ fontName Monospace = "monospace"+ fontName Handwriting = "cursive"+ fontName Fancy = "fantasy"+ fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\""++drawDrawing :: DrawState -> Drawing -> CanvasM ()+drawDrawing ds (Shape shape) = drawShape $ shape ds+drawDrawing ds (Transformation f d) = drawDrawing (f ds) d+drawDrawing ds (Drawings drs) = mapM_ (drawDrawing ds) (reverse drs)++findTopShape :: DrawState -> Drawing -> CanvasM (Bool, Int)+findTopShape ds (Shape drawer) = do+ contained <- shapeContains $ drawer ds+ case contained of+ True -> return (True, 0)+ False -> return (False, 1)+findTopShape ds (Transformation f d) =+ fmap (+ 1) <$> findTopShape (f ds) d+findTopShape ds (Drawings []) = return (False, 1)+findTopShape ds (Drawings (dr:drs)) = do+ (found, count) <- findTopShape ds dr+ case found of+ True -> return (True, count + 1)+ False -> fmap (+ count) <$> findTopShape ds (Drawings drs)++#ifdef ghcjs_HOST_OS++--------------------------------------------------------------------------------+-- GHCJS implementation of drawing++-- Debug Mode logic+inspect ::+ IO Picture -> (Bool -> IO ()) -> (Bool -> Maybe NodeId -> IO ()) -> IO ()+inspect getPic handleActive highlight =+ initDebugMode (handlePointRequest getPic) handleActive getPic highlight++handlePointRequest :: IO Picture -> Point -> IO (Maybe NodeId)+handlePointRequest getPic pt = do+ drawing <- pictureToDrawing <$> getPic+ findTopShapeFromPoint pt drawing++foreign import javascript unsafe "$1.drawImage($2, $3, $4, $5, $6);"+ canvasDrawImage :: Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()++foreign import javascript unsafe "$1.getContext('2d', { alpha: false })"+ getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context++foreign import javascript unsafe "showCanvas()"+ showCanvas :: IO ()++canvasFromElement :: Element -> Canvas.Canvas+canvasFromElement = Canvas.Canvas . unElement++elementFromCanvas :: Canvas.Canvas -> Element+elementFromCanvas = pFromJSVal . jsval++getTime :: IO Double+getTime = (/ 1000) <$> js_getHighResTimestamp++foreign import javascript unsafe "performance.now()"+ js_getHighResTimestamp :: IO Double++nextFrame :: IO Double+nextFrame = waitForAnimationFrame >> getTime++drawCodeWorldLogo ::+ DrawState -> Int -> Int -> Int -> Int -> CanvasM ()+drawCodeWorldLogo ds x y w h = do+ Just doc <- liftIO $ currentDocument+ Just canvas <- liftIO $ getElementById doc ("cwlogo" :: JSString)+ case getColorDS ds of+ Nothing -> CM.drawImage (canvasFromElement canvas) x y w h+ Just (RGBA r g b a)+ -- This is a tough case. The best we can do is to allocate an+ -- offscreen buffer as a temporary.+ -> do+ (img, _) <- CM.newImage w h $ do+ applyColor ds+ CM.fillRect 0 0 (fromIntegral w) (fromIntegral h)+ CM.globalCompositeOperation "destination-in"+ CM.drawImage (canvasFromElement canvas) 0 0 w h+ CM.drawImage img x y w h++initDebugMode ::+ (Point -> IO (Maybe NodeId))+ -> (Bool -> IO ())+ -> IO Picture+ -> (Bool -> Maybe NodeId -> IO ())+ -> IO ()+initDebugMode getnode setactive getpicture highlight = do+ getnodeCB <-+ syncCallback1' $ \pointJS -> do+ let obj = unsafeCoerce pointJS+ x <- pFromJSVal <$> getProp "x" obj+ y <- pFromJSVal <$> getProp "y" obj+ pToJSVal . fromMaybe (-1) <$> getnode (x, y)+ setactiveCB <- syncCallback1 ContinueAsync $ setactive . pFromJSVal+ getpictureCB <- syncCallback' $ getpicture >>= picToObj+ highlightCB <-+ syncCallback2 ContinueAsync $ \t n ->+ let select = pFromJSVal t+ node =+ case ((pFromJSVal n) :: Int) < 0 of+ True -> Nothing+ False -> Just $ pFromJSVal n+ in highlight select node+ drawCB <-+ syncCallback2 ContinueAsync $ \c n -> do+ let canvas = unsafeCoerce c :: Element+ nodeId = pFromJSVal n+ drawing <- pictureToDrawing <$> getpicture+ let node = fromMaybe (Drawings []) $ fst <$> getDrawNode nodeId drawing+ offscreenCanvas <- Canvas.create 500 500+ setCanvasSize canvas canvas+ setCanvasSize (elementFromCanvas offscreenCanvas) canvas+ screen <- getCodeWorldContext (canvasFromElement canvas)+ rect <- getBoundingClientRect canvas+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame (node <> coordinatePlaneDrawing)+ rect <- getBoundingClientRect canvas+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect+ canvasDrawImage+ screen+ (elementFromCanvas offscreenCanvas)+ 0+ 0+ (round cw)+ (round ch)+ js_initDebugMode getnodeCB setactiveCB getpictureCB highlightCB drawCB++foreign import javascript unsafe "initDebugMode($1,$2,$3,$4,$5)"+ js_initDebugMode :: Callback (JSVal -> IO JSVal)+ -> Callback (JSVal -> IO ())+ -> Callback (IO JSVal)+ -> Callback (JSVal -> JSVal -> IO ())+ -> Callback (JSVal -> JSVal -> IO ())+ -> IO ()++picToObj :: Picture -> IO JSVal+picToObj = fmap fst . flip State.runStateT 0 . picToObj'++picToObj' :: Picture -> State.StateT Int IO JSVal+picToObj' pic = objToJSVal <$> case pic of+ Pictures _ ps -> mkNodeWithChildren ps+ PictureAnd _ ps -> mkNodeWithChildren ps+ Color _ _ p -> mkNodeWithChild p+ Translate _ _ _ p -> mkNodeWithChild p+ Scale _ _ _ p -> mkNodeWithChild p+ Dilate _ _ p -> mkNodeWithChild p+ Rotate _ _ p -> mkNodeWithChild p+ _ -> mkSimpleNode+ where+ mkSimpleNode :: State.StateT Int IO Object+ mkSimpleNode = do+ obj <- liftIO create+ id <- do+ currentId <- State.get+ State.put (currentId + 1)+ return currentId+ liftIO $ do+ setProp "id" (pToJSVal id) obj+ setProp "name" (pToJSVal $ (trim 80 . describePicture) pic) obj+ case getPictureSrcLoc pic of+ Just loc -> do+ setProp "startLine" (pToJSVal $ srcLocStartLine loc) obj+ setProp "startCol" (pToJSVal $ srcLocStartCol loc) obj+ setProp "endLine" (pToJSVal $ srcLocEndLine loc) obj+ setProp "endCol" (pToJSVal $ srcLocEndCol loc) obj+ Nothing -> return ()+ return obj++ mkNodeWithChild :: Picture -> State.StateT Int IO Object+ mkNodeWithChild p = do+ obj <- mkSimpleNode+ subPic <- picToObj' p+ liftIO $ setProp "picture" subPic obj+ return obj++ mkNodeWithChildren :: [Picture] -> State.StateT Int IO Object+ mkNodeWithChildren ps = do+ obj <- mkSimpleNode+ arr <- liftIO $ Array.create+ mapM_ (\p -> picToObj' p >>= liftIO . flip Array.push arr) ps+ liftIO $ setProp "pictures" (unsafeCoerce arr) obj+ return obj++ objToJSVal = unsafeCoerce :: Object -> JSVal++trim :: Int -> String -> String+trim x y = let mid = (x - 2) `div` 2+ in case x >= (length y) of+ True -> y :: String+ False -> take mid y ++ ".." ++ (reverse $ take mid $ reverse y)++foreign import javascript unsafe "/\\bmode=haskell\\b/.test(location.search)"+ haskellMode :: Bool++showFloat :: Double -> String+showFloat x+ | haskellMode && x < 0 = "(" ++ result ++ ")"+ | otherwise = result+ where result = stripZeros (showFFloatAlt (Just 4) x "")+ stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse++showPoints :: [Point] -> String+showPoints pts =+ "[" +++ intercalate ", " [+ "(" ++ showFloat x ++ ", " ++ showFloat y ++ ")"+ | (x, y) <- pts+ ] +++ "]"++showColor :: Color -> String+showColor c@(RGBA r g b a)+ | c == black = "black"+ | c == white = "white"+ | c == red = "red"+ | c == green = "green"+ | c == blue = "blue"+ | c == yellow = "yellow"+ | c == orange = "orange"+ | c == brown = "brown"+ | c == pink = "pink"+ | c == purple = "purple"+ | c == gray = "gray"+ | haskellMode, a == 1 = printf "(RGB %s %s %s)" (showFloat r) (showFloat g) (showFloat b)+ | a == 1 = printf "RGB(%s, %s, %s)" (showFloat r) (showFloat g) (showFloat b)+ | haskellMode = printf "(RGBA %s %s %s %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a)+ | otherwise = printf "RGBA(%s, %s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a)++describePicture :: Picture -> String+describePicture (Rectangle _ w h)+ | haskellMode = printf "rectangle %s %s" (showFloat w) (showFloat h)+ | otherwise = printf "rectangle(%s, %s)" (showFloat w) (showFloat h)+describePicture (SolidRectangle _ w h)+ | haskellMode = printf "solidRectangle %s %s" (showFloat w) (showFloat h)+ | otherwise = printf "solidRectangle(%s, %s)" (showFloat w) (showFloat h)+describePicture (ThickRectangle _ lw w h)+ | haskellMode = printf "thickRectangle %s %s %s" (showFloat lw) (showFloat w) (showFloat h)+ | otherwise = printf "thickRectangle(%s, %s, %s)" (showFloat w) (showFloat h) (showFloat lw)+describePicture (Circle _ r)+ | haskellMode = printf "circle %s" (showFloat r)+ | otherwise = printf "circle(%s)" (showFloat r)+describePicture (SolidCircle _ r)+ | haskellMode = printf "solidCircle %s" (showFloat r)+ | otherwise = printf "solidCircle(%s)" (showFloat r)+describePicture (ThickCircle _ lw r)+ | haskellMode = printf "thickCircle %s %s" (showFloat lw) (showFloat r)+ | otherwise = printf "thickCircle(%s, %s)" (showFloat r) (showFloat lw)+describePicture (SolidPolygon _ pts)+ | haskellMode = printf "solidPolygon %s" (showPoints pts)+ | otherwise = printf "solidPolygon(%s)" (showPoints pts)+describePicture (SolidClosedCurve _ pts)+ | haskellMode = printf "solidClosedCurve %s" (showPoints pts)+ | otherwise = printf "solidClosedCurve(%s)" (showPoints pts)+describePicture (Polygon _ pts)+ | haskellMode = printf "polygon %s" (showPoints pts)+ | otherwise = printf "polygon(%s)" (showPoints pts)+describePicture (ThickPolygon _ pts w)+ | haskellMode = printf "thickPolygon %s %s" (showFloat w) (showPoints pts)+ | otherwise = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat w)+describePicture (ClosedCurve _ pts)+ | haskellMode = printf "closedCurve %s" (showPoints pts)+ | otherwise = printf "closedCurve(%s)" (showPoints pts)+describePicture (ThickClosedCurve _ pts w)+ | haskellMode = printf "thickClosedCurve %s %s" (showFloat w) (showPoints pts)+ | otherwise = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat w)+describePicture (Polyline _ pts)+ | haskellMode = printf "polyline %s" (showPoints pts)+ | otherwise = printf "polyline(%s)" (showPoints pts)+describePicture (ThickPolyline _ pts w)+ | haskellMode = printf "thickPolyline %s %s" (showFloat w) (showPoints pts)+ | otherwise = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat w)+describePicture (Curve _ pts)+ | haskellMode = printf "curve %s" (showPoints pts)+ | otherwise = printf "curve(%s)" (showPoints pts)+describePicture (ThickCurve _ pts w)+ | haskellMode = printf "thickCurve %s %s" (showFloat w) (showPoints pts)+ | otherwise = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat w)+describePicture (Sector _ b e r)+ | haskellMode = printf "sector %s %s %s" (showFloat b) (showFloat e) (showFloat r)+ | otherwise = printf "sector(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r)+describePicture (Arc _ b e r)+ | haskellMode = printf "arc %s %s %s" (showFloat b) (showFloat e) (showFloat r)+ | otherwise = printf "arc(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r)+describePicture (ThickArc _ b e r w)+ | haskellMode = printf "thickArc %s %s %s %s" (showFloat w) (showFloat b) (showFloat e) (showFloat r)+ | otherwise = printf "thickArc(%s°, %s°, %s, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) (showFloat w)+describePicture (Lettering _ txt)+ | haskellMode = printf "lettering %s" (show txt)+ | otherwise = printf "lettering(%s)" (show txt)+describePicture (Blank _) = "blank"+describePicture (StyledLettering _ style font txt)+ | haskellMode = printf "styledLettering %s %s %s" (showsPrec 10 style "") (showsPrec 10 font "") (show txt)+ | otherwise = printf "styledLettering(%s, %s, %s)" (show txt) (show font) (show style)+describePicture (Color _ c _)+ | haskellMode = printf "colored %s" (showColor c)+ | otherwise = printf "colored(..., %s)" (showColor c)+describePicture (Translate _ x y _)+ | haskellMode = printf "translated %s %s" (showFloat x) (showFloat y)+ | otherwise = printf "translated(..., %s, %s)" (showFloat x) (showFloat y)+describePicture (Scale _ x y _)+ | haskellMode = printf "scaled %s %s" (showFloat x) (showFloat y)+ | otherwise = printf "scaled(..., %s, %s)" (showFloat x) (showFloat y)+describePicture (Rotate _ angle _)+ | haskellMode = printf "rotated %s" (showFloat angle)+ | otherwise = printf "rotated(..., %s°)" (showFloat (180 * angle / pi))+describePicture (Dilate _ k _)+ | haskellMode = printf "dilated %s" (showFloat k)+ | otherwise = printf "dilated(..., %s)" (showFloat k)+describePicture (Logo _) = "codeWorldLogo"+describePicture (CoordinatePlane _) = "coordinatePlane"+describePicture (Pictures _ _)+ | haskellMode = "pictures"+ | otherwise = "pictures(...)"+describePicture (PictureAnd _ _)+ | haskellMode = "(&)"+ | otherwise = "... & ..."++getPictureSrcLoc :: Picture -> Maybe SrcLoc+getPictureSrcLoc (SolidPolygon loc _) = loc+getPictureSrcLoc (SolidClosedCurve loc _) = loc+getPictureSrcLoc (Polygon loc _) = loc+getPictureSrcLoc (ThickPolygon loc _ _) = loc+getPictureSrcLoc (Rectangle loc _ _) = loc+getPictureSrcLoc (SolidRectangle loc _ _) = loc+getPictureSrcLoc (ThickRectangle loc _ _ _) = loc+getPictureSrcLoc (ClosedCurve loc _) = loc+getPictureSrcLoc (ThickClosedCurve loc _ _) = loc+getPictureSrcLoc (Circle loc _) = loc+getPictureSrcLoc (SolidCircle loc _) = loc+getPictureSrcLoc (ThickCircle loc _ _) = loc+getPictureSrcLoc (Polyline loc _) = loc+getPictureSrcLoc (ThickPolyline loc _ _) = loc+getPictureSrcLoc (Curve loc _) = loc+getPictureSrcLoc (ThickCurve loc _ _) = loc+getPictureSrcLoc (Sector loc _ _ _) = loc+getPictureSrcLoc (Arc loc _ _ _) = loc+getPictureSrcLoc (ThickArc loc _ _ _ _) = loc+getPictureSrcLoc (Lettering loc _) = loc+getPictureSrcLoc (Blank loc) = loc+getPictureSrcLoc (StyledLettering loc _ _ _) = loc+getPictureSrcLoc (Color loc _ _) = loc+getPictureSrcLoc (Translate loc _ _ _) = loc+getPictureSrcLoc (Scale loc _ _ _) = loc+getPictureSrcLoc (Dilate loc _ _) = loc+getPictureSrcLoc (Rotate loc _ _) = loc+getPictureSrcLoc (Logo loc) = loc+getPictureSrcLoc (CoordinatePlane loc) = loc+getPictureSrcLoc (Pictures loc _) = loc+getPictureSrcLoc (PictureAnd loc _) = loc++-- If a picture is found, the result will include an array of the base picture+-- and all transformations.+findTopShapeFromPoint :: Point -> Drawing -> IO (Maybe NodeId)+findTopShapeFromPoint (x, y) pic = do+ buf <- Canvas.create 500 500+ ctx <- Canvas.getContext buf+ (found, node) <- runCanvasM ctx $+ findTopShape (translateDS (10 - x / 25) (y / 25 - 10) initialDS)+ pic+ case found of+ True -> return $ Just node+ False -> return Nothing++drawFrame :: Drawing -> CanvasM ()+drawFrame drawing = do+ CM.fillColor 255 255 255 1+ CM.fillRect (-250) (-250) 500 500+ drawDrawing initialDS drawing++withScreen :: Element -> ClientRect.ClientRect -> CanvasM a -> IO a+withScreen canvas rect action = do+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect+ ctx <- getCodeWorldContext (canvasFromElement canvas)+ runCanvasM ctx $ CM.saveRestore $ do+ CM.translate (realToFrac cw / 2) (realToFrac ch / 2)+ CM.scale (realToFrac cw / 500) (-realToFrac ch / 500)+ CM.lineWidth 0+ CM.textCenter+ CM.textMiddle+ action++setCanvasSize :: Element -> Element -> IO ()+setCanvasSize target canvas = do+ rect <- getBoundingClientRect canvas+ cx <- ClientRect.getWidth rect+ cy <- ClientRect.getHeight rect+ setAttribute target ("width" :: JSString) (show (round cx))+ setAttribute target ("height" :: JSString) (show (round cy))++#else++--------------------------------------------------------------------------------+-- Stand-alone implementation of drawing++drawCodeWorldLogo ::+ DrawState -> Int -> Int -> Int -> Int -> CanvasM ()+drawCodeWorldLogo ds x y w h = return ()++setupScreenContext :: (Int, Int) -> Canvas ()+setupScreenContext (cw, ch)+ -- blank before transformation (canvas might be non-sqare)+ = do+ Canvas.fillStyle "white"+ Canvas.fillRect (0, 0, fromIntegral cw, fromIntegral ch)+ Canvas.translate (realToFrac cw / 2, realToFrac ch / 2)+ let s = min (realToFrac cw / 500) (realToFrac ch / 500)+ Canvas.scale (s, -s)+ Canvas.lineWidth 0+ Canvas.textAlign Canvas.CenterAnchor+ Canvas.textBaseline Canvas.MiddleBaseline++type Port = Int++readPortFromEnv :: String -> Port -> IO Port+readPortFromEnv envName defaultPort = do+ ms <- lookupEnv envName+ return (fromMaybe defaultPort (ms >>= readMaybe))++runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO ()+runBlankCanvas act = do+ port <- readPortFromEnv "CODEWORLD_API_PORT" 3000+ let options =+ (fromIntegral port)+ { Canvas.events =+ ["mousedown", "mouseup", "mousemove", "keydown", "keyup"]+ }+ putStrLn $ printf "Open me on http://127.0.0.1:%d/" (Canvas.port options)+ Canvas.blankCanvas options $ \context -> do+ putStrLn "Program is starting..."+ act context++#endif++--------------------------------------------------------------------------------+-- Common event handling and core interaction code++keyCodeToText :: Word -> Text+keyCodeToText n =+ case n of+ _+ | n >= 47 && n <= 90 -> fromAscii n+ _+ | n >= 96 && n <= 105 -> fromNum (n - 96)+ _+ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111)+ 3 -> "Cancel"+ 6 -> "Help"+ 8 -> "Backspace"+ 9 -> "Tab"+ 12 -> "5"+ 13 -> "Enter"+ 16 -> "Shift"+ 17 -> "Ctrl"+ 18 -> "Alt"+ 19 -> "Break"+ 20 -> "CapsLock"+ 27 -> "Esc"+ 32 -> " "+ 33 -> "PageUp"+ 34 -> "PageDown"+ 35 -> "End"+ 36 -> "Home"+ 37 -> "Left"+ 38 -> "Up"+ 39 -> "Right"+ 40 -> "Down"+ 42 -> "*"+ 43 -> "+"+ 44 -> "PrintScreen"+ 45 -> "Insert"+ 46 -> "Delete"+ 47 -> "Help"+ 91 -> "OS"+ 92 -> "OS"+ 93 -> "ContextMenu"+ 106 -> "*"+ 107 -> "+"+ 108 -> ","+ 109 -> "-"+ 110 -> "."+ 111 -> "/"+ 144 -> "NumLock"+ 145 -> "ScrollLock"+ 173 -> "-"+ 186 -> ";"+ 187 -> "="+ 188 -> ","+ 189 -> "-"+ 190 -> "."+ 191 -> "/"+ 192 -> "`"+ 193 -> "IntlRo"+ 194 -> ","+ 219 -> "["+ 220 -> "\\"+ 221 -> "]"+ 222 -> "'"+ 225 -> "AltGraph"+ 255 -> "IntlYen"+ _ -> "Unknown:" <> fromNum n+ where+ fromAscii n = singleton (chr (fromIntegral n))+ fromNum n = pack (show (fromIntegral n))++isUniversallyConstant :: (a -> s -> s) -> s -> Bool+isUniversallyConstant f old =+ unsafePerformIO $ falseOr $ do+ oldName <- makeStableName $! old+ genName <- makeStableName $! f undefined old+ return (genName == oldName)+ where+ falseOr x = x `catch` \(e :: SomeException) -> return False++ifDifferent :: (s -> s) -> s -> Maybe s+ifDifferent f s0 = unsafePerformIO $ do+ oldName <- makeStableName $! s0+ newName <- makeStableName $! s1+ if newName == oldName then return Nothing else return (Just s1)+ where s1 = f s0++modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool+modifyMVarIfDifferent var f =+ modifyMVar var $ \s0 -> do+ case ifDifferent f s0 of+ Nothing -> return (s0, False)+ Just s1 -> return (s1, True)++data GameToken+ = FullToken { tokenDeployHash :: Text+ , tokenNumPlayers :: Int+ , tokenInitial :: StaticKey+ , tokenStep :: StaticKey+ , tokenEvent :: StaticKey+ , tokenDraw :: StaticKey }+ | SteplessToken { tokenDeployHash :: Text+ , tokenNumPlayers :: Int+ , tokenInitial :: StaticKey+ , tokenEvent :: StaticKey+ , tokenDraw :: StaticKey }+ | PartialToken { tokenDeployHash :: Text }+ | NoToken+ deriving (Generic)++deriving instance Generic Fingerprint++instance Serialize Fingerprint++instance Serialize GameToken++#ifdef ghcjs_HOST_OS++--------------------------------------------------------------------------------+-- GHCJS event handling and core interaction code++getMousePos :: IsMouseEvent e => Element -> EventM w e Point+getMousePos canvas = do+ (ix, iy) <- mouseClientXY+ liftIO $ do+ rect <- getBoundingClientRect canvas+ cx <- ClientRect.getLeft rect+ cy <- ClientRect.getTop rect+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect+ return+ ( 20 * fromIntegral (ix - round cx) / realToFrac cw - 10+ , 20 * fromIntegral (round cy - iy) / realToFrac cw + 10)++onEvents :: Element -> (Event -> IO ()) -> IO ()+onEvents canvas handler = do+ Just window <- currentWindow+ on window keyDown $ do+ code <- uiKeyCode+ let keyName = keyCodeToText code+ when (keyName /= "") $ do+ liftIO $ handler (KeyPress keyName)+ preventDefault+ stopPropagation+ on window keyUp $ do+ code <- uiKeyCode+ let keyName = keyCodeToText code+ when (keyName /= "") $ do+ liftIO $ handler (KeyRelease keyName)+ preventDefault+ stopPropagation+ on window mouseDown $ do+ pos <- getMousePos canvas+ liftIO $ handler (PointerPress pos)+ on window mouseUp $ do+ pos <- getMousePos canvas+ liftIO $ handler (PointerRelease pos)+ on window mouseMove $ do+ pos <- getMousePos canvas+ liftIO $ handler (PointerMovement pos)+ return ()++encodeEvent :: (Timestamp, Maybe Event) -> String+encodeEvent = show++decodeEvent :: String -> Maybe (Timestamp, Maybe Event)+decodeEvent = readMaybe++data GameState s+ = Main (UIState SMain)+ | Connecting WS.WebSocket+ (UIState SConnect)+ | Waiting WS.WebSocket+ GameId+ PlayerId+ (UIState SWait)+ | Running WS.WebSocket+ GameId+ Timestamp+ PlayerId+ (Future s)++isRunning :: GameState s -> Bool+isRunning Running {} = True+isRunning _ = False++gameTime :: GameState s -> Timestamp -> Double+gameTime (Running _ _ tstart _ _) t = t - tstart+gameTime _ _ = 0++-- It's worth trying to keep the canonical animation rate exactly representable+-- as a float, to minimize the chance of divergence due to rounding error.+gameRate :: Double+gameRate = 1 / 16++gameStep :: (Double -> s -> s) -> Double -> GameState s -> GameState s+gameStep _ t (Main s) = Main (CUI.step t s)+gameStep _ t (Connecting ws s) = Connecting ws (CUI.step t s)+gameStep _ t (Waiting ws gid pid s) = Waiting ws gid pid (CUI.step t s)+gameStep step t (Running ws gid tstart pid s) =+ Running ws gid tstart pid (currentTimePasses step gameRate (t - tstart) s)++gameDraw ::+ (Double -> s -> s)+ -> (PlayerId -> s -> Picture)+ -> GameState s+ -> Timestamp+ -> Picture+gameDraw _ _ (Main s) _ = CUI.picture s+gameDraw _ _ (Connecting _ s) _ = CUI.picture s+gameDraw _ _ (Waiting _ _ _ s) _ = CUI.picture s+gameDraw step draw (Running _ _ tstart pid s) t =+ draw pid (currentState step gameRate (t - tstart) s)++handleServerMessage ::+ Int+ -> (StdGen -> s)+ -> (Double -> s -> s)+ -> (PlayerId -> Event -> s -> s)+ -> MVar (GameState s)+ -> ServerMessage+ -> IO ()+handleServerMessage numPlayers initial stepHandler eventHandler gsm sm = do+ modifyMVar_ gsm $ \gs -> do+ t <- getTime+ case (sm, gs) of+ (GameAborted, _) -> return initialGameState+ (JoinedAs pid gid, Connecting ws s) ->+ return (Waiting ws gid pid (CUI.startWaiting gid s))+ (PlayersWaiting m n, Waiting ws gid pid s) ->+ return (Waiting ws gid pid (CUI.updatePlayers n m s))+ (Started, Waiting ws gid pid _) ->+ return+ (Running+ ws+ gid+ t+ pid+ (initFuture (initial (mkStdGen (hash gid))) numPlayers))+ (OutEvent pid eo, Running ws gid tstart mypid s) ->+ case decodeEvent eo of+ Just (t', event) ->+ let ours = pid == mypid+ func = eventHandler pid <$> event -- might be a ping (Nothing)+ result+ | ours = s -- we already took care of our events+ | otherwise =+ addEvent+ stepHandler+ gameRate+ mypid+ t'+ func+ s+ in return (Running ws gid tstart mypid result)+ Nothing -> return (Running ws gid tstart mypid s)+ _ -> return gs+ return ()++gameHandle ::+ Int+ -> (StdGen -> s)+ -> (Double -> s -> s)+ -> (PlayerId -> Event -> s -> s)+ -> GameToken+ -> MVar (GameState s)+ -> Event+ -> IO ()+gameHandle numPlayers initial stepHandler eventHandler token gsm event = do+ gs <- takeMVar gsm+ case gs of+ Main s ->+ case CUI.event event s of+ ContinueMain s' -> do+ putMVar gsm (Main s')+ Create s' -> do+ ws <-+ connectToGameServer+ (handleServerMessage+ numPlayers+ initial+ stepHandler+ eventHandler+ gsm)+ sendClientMessage ws (NewGame numPlayers (encode token))+ putMVar gsm (Connecting ws s')+ Join gid s' -> do+ ws <-+ connectToGameServer+ (handleServerMessage+ numPlayers+ initial+ stepHandler+ eventHandler+ gsm)+ sendClientMessage ws (JoinGame gid (encode token))+ putMVar gsm (Connecting ws s')+ Connecting ws s ->+ case CUI.event event s of+ ContinueConnect s' -> do+ putMVar gsm (Connecting ws s')+ CancelConnect s' -> do+ WS.close Nothing Nothing ws+ putMVar gsm (Main s')+ Waiting ws gid pid s ->+ case CUI.event event s of+ ContinueWait s' -> do+ putMVar gsm (Waiting ws gid pid s')+ CancelWait s' -> do+ WS.close Nothing Nothing ws+ putMVar gsm (Main s')+ Running ws gid tstart pid f -> do+ t <- getTime+ let gameState0 = currentState stepHandler gameRate (t - tstart) f+ let eventFun = eventHandler pid event+ case ifDifferent eventFun gameState0 of+ Nothing -> putMVar gsm gs+ Just s1 -> do+ sendClientMessage+ ws+ (InEvent (encodeEvent (gameTime gs t, Just event)))+ let f1 =+ addEvent+ stepHandler+ gameRate+ pid+ (t - tstart)+ (Just eventFun)+ f+ putMVar gsm (Running ws gid tstart pid f1)++getWebSocketURL :: IO JSString+getWebSocketURL = do+ loc <- Loc.getWindowLocation+ proto <- Loc.getProtocol loc+ hostname <- Loc.getHostname loc+ let url =+ case proto of+ "http:" -> "ws://" <> hostname <> ":9160/gameserver"+ "https:" -> "wss://" <> hostname <> "/gameserver"+ _ -> error "Unrecognized protocol"+ return url++connectToGameServer :: (ServerMessage -> IO ()) -> IO WS.WebSocket+connectToGameServer handleServerMessage = do+ let handleWSRequest m = do+ maybeSM <- decodeServerMessage m+ case maybeSM of+ Nothing -> return ()+ Just sm -> handleServerMessage sm+ wsURL <- getWebSocketURL+ let req =+ WS.WebSocketRequest+ { url = wsURL+ , protocols = []+ , onClose = Just $ \_ -> handleServerMessage GameAborted+ , onMessage = Just handleWSRequest+ }+ WS.connect req+ where+ decodeServerMessage :: WS.MessageEvent -> IO (Maybe ServerMessage)+ decodeServerMessage m =+ case WS.getData m of+ WS.StringData str -> do+ return $ readMaybe (Data.JSString.unpack str)+ _ -> return Nothing+ encodeClientMessage :: ClientMessage -> JSString+ encodeClientMessage m = Data.JSString.pack (show m)++sendClientMessage :: WS.WebSocket -> ClientMessage -> IO ()+sendClientMessage ws msg = WS.send (encodeClientMessage msg) ws+ where+ encodeClientMessage :: ClientMessage -> JSString+ encodeClientMessage m = Data.JSString.pack (show m)++initialGameState :: GameState s+initialGameState = Main CUI.initial++foreign import javascript unsafe "cw$deterministic_math();"+ enableDeterministicMath :: IO ()++runGame ::+ GameToken+ -> Int+ -> (StdGen -> s)+ -> (Double -> s -> s)+ -> (Int -> Event -> s -> s)+ -> (Int -> s -> Picture)+ -> IO ()+runGame token numPlayers initial stepHandler eventHandler drawHandler = do+ enableDeterministicMath+ let fullStepHandler dt = stepHandler dt . eventHandler (-1) (TimePassing dt)+ showCanvas+ Just window <- currentWindow+ Just doc <- currentDocument+ Just canvas <- getElementById doc ("screen" :: JSString)+ offscreenCanvas <- Canvas.create 500 500+ setCanvasSize canvas canvas+ setCanvasSize (elementFromCanvas offscreenCanvas) canvas+ on window resize $ do+ liftIO $ setCanvasSize canvas canvas+ liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas+ currentGameState <- newMVar initialGameState+ onEvents canvas $+ gameHandle+ numPlayers+ initial+ fullStepHandler+ eventHandler+ token+ currentGameState+ screen <- getCodeWorldContext (canvasFromElement canvas)+ let go t0 lastFrame = do+ gs <- readMVar currentGameState+ let pic = gameDraw fullStepHandler drawHandler gs t0+ picFrame <- makeStableName $! pic+ when (picFrame /= lastFrame) $ do+ rect <- getBoundingClientRect canvas+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame (pictureToDrawing pic)+ rect <- getBoundingClientRect canvas+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect+ when (cw > 0 && ch > 0) $ canvasDrawImage+ screen+ (elementFromCanvas offscreenCanvas)+ 0+ 0+ (round cw)+ (round ch)+ t1 <- nextFrame+ modifyMVar_ currentGameState $ return . gameStep fullStepHandler t1+ go t1 picFrame+ t0 <- getTime+ nullFrame <- makeStableName undefined+ initialStateName <- makeStableName $! initialGameState+ go t0 nullFrame++getDeployHash :: IO Text+getDeployHash = pFromJSVal <$> js_getDeployHash++foreign import javascript "/[&?]dhash=(.{22})/.exec(window.location.search)[1]"+ js_getDeployHash :: IO JSVal++foreign import javascript "console.log($1);"+ js_debugLog :: JSString -> IO ()++debugLog :: String -> IO ()+debugLog = js_debugLog . Data.JSString.pack++propagateErrors :: ThreadId -> IO () -> IO ()+propagateErrors tid action = action `catch` \ (e :: SomeException) -> throwTo tid e++run :: s+ -> (Double -> s -> s)+ -> (e -> s -> s)+ -> (s -> Drawing)+ -> (Double -> e)+ -> IO (e -> IO (), IO s)+run initial stepHandler eventHandler drawHandler injectTime = do+ let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt)+ showCanvas+ Just window <- currentWindow+ Just doc <- currentDocument+ Just canvas <- getElementById doc ("screen" :: JSString)+ offscreenCanvas <- Canvas.create 500 500+ setCanvasSize canvas canvas+ setCanvasSize (elementFromCanvas offscreenCanvas) canvas+ needsRedraw <- newMVar ()+ on window resize $ void $ liftIO $ do+ setCanvasSize canvas canvas+ setCanvasSize (elementFromCanvas offscreenCanvas) canvas+ tryPutMVar needsRedraw ()+ currentState <- newMVar initial+ eventHappened <- newMVar ()+ screen <- getCodeWorldContext (canvasFromElement canvas)+ let go t0 lastFrame lastStateName needsTime = do+ pic <- drawHandler <$> readMVar currentState+ picFrame <- makeStableName $! pic+ when (picFrame /= lastFrame) $ do+ rect <- getBoundingClientRect canvas+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame pic+ rect <- getBoundingClientRect canvas+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect+ when (cw > 0 && ch > 0) $ canvasDrawImage+ screen+ (elementFromCanvas offscreenCanvas)+ 0+ 0+ (round cw)+ (round ch)+ t1 <-+ if | needsTime ->+ do t1 <- nextFrame+ let dt = min (t1 - t0) 0.25+ modifyMVarIfDifferent currentState (fullStepHandler dt)+ return t1+ | otherwise ->+ do takeMVar eventHappened+ getTime+ nextState <- readMVar currentState+ nextStateName <- makeStableName $! nextState+ let nextNeedsTime =+ nextStateName /= lastStateName ||+ needsTime && not (isUniversallyConstant fullStepHandler nextState)+ nextFrame <- tryTakeMVar needsRedraw >>= \case+ Nothing -> return picFrame+ Just () -> makeStableName undefined+ go t1 nextFrame nextStateName nextNeedsTime+ t0 <- getTime+ nullFrame <- makeStableName undefined+ initialStateName <- makeStableName $! initial+ mainThread <- myThreadId+ drawThread <- forkIO $ propagateErrors mainThread $+ go t0 nullFrame initialStateName True+ let sendEvent event = propagateErrors drawThread $ do+ changed <-+ modifyMVarIfDifferent currentState (eventHandler event)+ when changed $ void $ tryPutMVar eventHappened ()+ getState = readMVar currentState+ return (sendEvent, getState)++data DebugState = DebugState+ { debugStateActive :: Bool+ , shapeHighlighted :: Maybe NodeId+ , shapeSelected :: Maybe NodeId+ }++data DebugEvent+ = DebugStart+ | DebugStop+ | HighlightEvent (Maybe NodeId)+ | SelectEvent (Maybe NodeId)++debugStateInit :: DebugState+debugStateInit = DebugState False Nothing Nothing++updateDebugState :: DebugEvent -> DebugState -> DebugState+updateDebugState DebugStart prev = DebugState True Nothing Nothing+updateDebugState DebugStop prev = DebugState False Nothing Nothing+updateDebugState (HighlightEvent n) prev =+ case debugStateActive prev of+ True -> prev {shapeHighlighted = n}+ False -> DebugState False Nothing Nothing+updateDebugState (SelectEvent n) prev =+ case debugStateActive prev of+ True -> prev {shapeSelected = n}+ False -> DebugState False Nothing Nothing++drawDebugState :: DebugState -> Drawing -> Drawing+drawDebugState state drawing =+ case debugStateActive state of+ True ->+ highlightSelectShape+ (shapeHighlighted state)+ (shapeSelected state)+ drawing+ False -> drawing++-- Utility functions that apply a function in either the left or right half of a+-- tuple. Crucially, if the function preserves sharing on its side, then the+-- wrapper also preserves sharing.+inLeft :: (a -> a) -> (a, b) -> (a, b)+inLeft f ab = unsafePerformIO $ do+ let (a, b) = ab+ aName <- makeStableName $! a+ let a' = f a+ aName' <- makeStableName $! a'+ return $ if aName == aName' then ab else (a', b)++inRight :: (b -> b) -> (a, b) -> (a, b)+inRight f ab = unsafePerformIO $ do+ let (a, b) = ab+ bName <- makeStableName $! b+ let b' = f b+ bName' <- makeStableName $! b'+ return $ if bName == bName' then ab else (a, b')++foreign import javascript interruptible "window.dummyVar = 0;"+ waitForever :: IO ()++-- Wraps the event and state from run so they can be paused by pressing the Inspect+-- button.+runInspect :: + (Wrapped s -> [Control s])+ -> s+ -> (Double -> s -> s)+ -> (Event -> s -> s)+ -> (s -> Picture) + -> IO ()+runInspect controls initial stepHandler eventHandler drawHandler = do+ Just window <- currentWindow+ Just doc <- currentDocument+ Just canvas <- getElementById doc ("screen" :: JSString)+ let initialWrapper = (debugStateInit, wrappedInitial initial)+ stepHandlerWrapper dt wrapper@(debugState, _) =+ case debugStateActive debugState of+ True -> wrapper+ False -> inRight (wrappedStep stepHandler dt) wrapper+ eventHandlerWrapper evt wrapper@(debugState, _) =+ case (debugStateActive debugState, evt) of+ (_, Left debugEvent) ->+ inLeft (updateDebugState debugEvent) wrapper+ (True, _) -> wrapper+ (_, Right normalEvent) ->+ inRight (wrappedEvent controls stepHandler eventHandler normalEvent) wrapper+ drawHandlerWrapper (debugState, wrappedState) =+ case debugStateActive debugState of+ True -> drawDebugState debugState $ pictureToDrawing $ drawHandler (state wrappedState)+ False -> pictureToDrawing (wrappedDraw controls drawHandler wrappedState)+ drawPicHandler (debugState, wrappedState) =+ drawHandler $ state wrappedState+ (sendEvent, getState) <-+ run+ initialWrapper+ stepHandlerWrapper+ (\e w -> (eventHandlerWrapper e) w)+ drawHandlerWrapper+ (Right . TimePassing)+ let pauseEvent True = sendEvent $ Left DebugStart+ pauseEvent False = sendEvent $ Left DebugStop+ highlightSelectEvent True n = sendEvent $ Left (HighlightEvent n)+ highlightSelectEvent False n = sendEvent $ Left (SelectEvent n)+ onEvents canvas (sendEvent . Right)+ inspect (drawPicHandler <$> getState) pauseEvent highlightSelectEvent+ waitForever++-- Given a drawing, highlight the first node and select second node. Both recolor+-- the nodes, but highlight also brings the node to the top.+highlightSelectShape :: Maybe NodeId -> Maybe NodeId -> Drawing -> Drawing+highlightSelectShape h s drawing+ | isNothing s =+ fromMaybe drawing $ do+ h' <- h+ hp <- piece h'+ return $ hp <> drawing+ | isNothing h =+ fromMaybe drawing $ do+ s' <- s+ sp <- piece s'+ replaceDrawNode s' sp drawing+ | otherwise =+ fromMaybe drawing $ do+ h' <- h+ s' <- s+ hp <- piece h'+ sp <- piece s'+ replaced <- replaceDrawNode s' sp drawing+ return $ hp <> replaced+ where+ piece n =+ (\(node, ds) -> highlightDrawing ds node) <$> getDrawNode n drawing++highlightDrawing :: DrawState -> Drawing -> Drawing+highlightDrawing (a, b, c, d, e, f, _) drawing =+ Transformation (\_ -> (a, b, c, d, e, f, Just col')) drawing+ where+ col' = RGBA 0 0 0 0.25++getDrawNode :: NodeId -> Drawing -> Maybe (Drawing, DrawState)+getDrawNode n _+ | n < 0 = Nothing+getDrawNode n drawing = either Just (const Nothing) $ go initialDS n drawing+ where+ go ds 0 d = Left (d, ds)+ go ds n (Shape _) = Right (n - 1)+ go ds n (Transformation f dr) = go (f ds) (n - 1) dr+ go ds n (Drawings []) = Right (n - 1)+ go ds n (Drawings (dr:drs)) =+ case go ds (n - 1) dr of+ Left d -> Left d+ Right n -> go ds (n + 1) $ Drawings drs++replaceDrawNode :: NodeId -> Drawing -> Drawing -> Maybe Drawing+replaceDrawNode n _ _+ | n < 0 = Nothing+replaceDrawNode n with drawing = either Just (const Nothing) $ go n drawing+ where+ go :: Int -> Drawing -> Either Drawing Int+ go 0 _ = Left with+ go n (Shape _) = Right (n - 1)+ go n (Transformation f d) = mapLeft (Transformation f) $ go (n - 1) d+ go n (Drawings []) = Right (n - 1)+ go n (Drawings (dr:drs)) =+ case go (n - 1) dr of+ Left d -> Left $ Drawings (d : drs)+ Right m ->+ mapLeft (\(Drawings qs) -> Drawings (dr : qs)) $+ go (m + 1) $ Drawings drs+ mapLeft :: (a -> b) -> Either a c -> Either b c+ mapLeft f = either (Left . f) Right++#else++debugLog :: String -> IO ()+debugLog = putStrLn++--------------------------------------------------------------------------------+-- Stand-Alone event handling and core interaction code++getMousePos :: (Int, Int) -> (Double, Double) -> (Double, Double)+getMousePos (w, h) (x, y) =+ ((x - fromIntegral w / 2) / s, -(y - fromIntegral h / 2) / s)+ where+ s = min (realToFrac w / 20) (realToFrac h / 20)++toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event+toEvent rect Canvas.Event {..}+ | eType == "keydown"+ , Just code <- eWhich = Just $ KeyPress (keyCodeToText (fromIntegral code))+ | eType == "keyup"+ , Just code <- eWhich =+ Just $ KeyRelease (keyCodeToText (fromIntegral code))+ | eType == "mousedown"+ , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerPress pos+ | eType == "mouseup"+ , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerRelease pos+ | eType == "mousemove"+ , Just pos <- getMousePos rect <$> ePageXY = Just $ PointerMovement pos+ | otherwise = Nothing++onEvents :: Canvas.DeviceContext -> (Int, Int) -> (Event -> IO ()) -> IO ()+onEvents context rect handler =+ void $+ forkIO $+ forever $ do+ maybeEvent <- toEvent rect <$> Canvas.wait context+ forM_ maybeEvent handler++run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO ()+run initial stepHandler eventHandler drawHandler =+ runBlankCanvas $ \context -> do+ let fullStepHandler dt = stepHandler dt . eventHandler (TimePassing dt)+ let rect = (Canvas.width context, Canvas.height context)+ offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect+ currentState <- newMVar initial+ eventHappened <- newMVar ()+ onEvents context rect $ \event -> do+ modifyMVar_ currentState (return . eventHandler event)+ tryPutMVar eventHappened ()+ return ()+ let go t0 lastFrame lastStateName needsTime = do+ pic <- drawHandler <$> readMVar currentState+ picFrame <- makeStableName $! pic+ when (picFrame /= lastFrame) $+ Canvas.send context $ do+ Canvas.with offscreenCanvas $+ Canvas.saveRestore $ do+ setupScreenContext rect+ drawDrawing initialDS (pictureToDrawing pic)+ Canvas.drawImageAt (offscreenCanvas, 0, 0)+ t1 <-+ if | needsTime ->+ do tn <- getCurrentTime+ threadDelay $+ max+ 0+ (50000 -+ round ((tn `diffUTCTime` t0) * 1000000))+ t1 <- getCurrentTime+ let dt = realToFrac (t1 `diffUTCTime` t0)+ modifyMVar_ currentState (return . fullStepHandler dt)+ return t1+ | otherwise ->+ do takeMVar eventHappened+ getCurrentTime+ nextState <- readMVar currentState+ nextStateName <- makeStableName $! nextState+ let nextNeedsTime =+ nextStateName /= lastStateName ||+ needsTime && not (isUniversallyConstant fullStepHandler nextState)+ go t1 picFrame nextStateName nextNeedsTime+ t0 <- getCurrentTime+ nullFrame <- makeStableName undefined+ initialStateName <- makeStableName $! initial+ go t0 nullFrame initialStateName True++runInspect :: + (Wrapped s -> [Control s])+ -> s+ -> (Double -> s -> s)+ -> (Event -> s -> s)+ -> (s -> Picture) + -> IO ()+runInspect controls initial stepHandler eventHandler drawHandler =+ run (wrappedInitial initial)+ (wrappedStep stepHandler)+ (wrappedEvent controls stepHandler eventHandler)+ (wrappedDraw controls drawHandler)++getDeployHash :: IO Text+getDeployHash = error "game API unimplemented in stand-alone interface mode"++runGame ::+ GameToken+ -> Int+ -> (StdGen -> s)+ -> (Double -> s -> s)+ -> (Int -> Event -> s -> s)+ -> (Int -> s -> Picture)+ -> IO ()+runGame = error "game API unimplemented in stand-alone interface mode"++#endif++--------------------------------------------------------------------------------+-- Common code for game interface++groupActivityOf numPlayers initial event draw = do+ dhash <- getDeployHash+ let token =+ SteplessToken+ { tokenDeployHash = dhash+ , tokenNumPlayers = numPlayers+ , tokenInitial = staticKey initial+ , tokenEvent = staticKey event+ , tokenDraw = staticKey draw+ }+ runGame+ token+ numPlayers+ (deRefStaticPtr initial)+ (const id)+ (deRefStaticPtr event)+ (deRefStaticPtr draw)++unsafeGroupActivityOf numPlayers initial event draw =+ unsafeCollaborationOf numPlayers initial (const id) event draw++unsafeCollaborationOf numPlayers initial step event draw = do+ dhash <- getDeployHash+ let token = PartialToken dhash+ runGame token numPlayers initial step event draw+ where+ token = NoToken++collaborationOf numPlayers initial step event draw = do+ dhash <- getDeployHash+ let token =+ FullToken+ { tokenDeployHash = dhash+ , tokenNumPlayers = numPlayers+ , tokenInitial = staticKey initial+ , tokenStep = staticKey step+ , tokenEvent = staticKey event+ , tokenDraw = staticKey draw+ }+ runGame+ token+ numPlayers+ (deRefStaticPtr initial)+ (deRefStaticPtr step)+ (deRefStaticPtr event)+ (deRefStaticPtr draw)++--------------------------------------------------------------------------------+-- Common code for activity, interaction, animation and simulation interfaces++activityOf initial change picture =+ interactionOf initial (const id) change picture++interactionOf = runInspect (const [])++data Wrapped a = Wrapped+ { state :: a+ , playbackSpeed :: Double+ , lastInteractionTime :: Double+ , zoomFactor :: Double+ , panCenter :: Point+ , panDraggingAnchor :: Maybe Point+ , isDraggingSpeed :: Bool+ , isDraggingHistory :: Bool+ , isDraggingZoom :: Bool+ } deriving (Show, Functor)++data Control :: * -> * where+ PlayButton :: Point -> Control a+ PauseButton :: Point -> Control a+ StepButton :: Point -> Control a+ RestartButton :: Point -> Control Double+ ZoomInButton :: Point -> Control a+ ZoomOutButton :: Point -> Control a+ PanningLayer :: Control a+ ResetViewButton :: Point -> Control a+ FastForwardButton :: Point -> Control a+ StartOverButton :: Point -> Control ([a], [a])+ BackButton :: Point -> Control Double+ TimeLabel :: Point -> Control Double+ SpeedSlider :: Point -> Control a+ ZoomSlider :: Point -> Control a+ UndoButton :: Point -> Control ([a], [a])+ RedoButton :: Point -> Control ([a], [a])+ HistorySlider :: Point -> Control ([a], [a])++wrappedInitial :: a -> Wrapped a+wrappedInitial w = Wrapped { + state = w,+ playbackSpeed = 1,+ lastInteractionTime = 1000,+ zoomFactor = 1,+ panCenter = (0,0),+ panDraggingAnchor = Nothing,+ isDraggingSpeed = False,+ isDraggingHistory = False,+ isDraggingZoom = False+ }++toState :: (a -> a) -> (Wrapped a -> Wrapped a)+toState f w = case ifDifferent f (state w) of+ Just newState -> w { state = newState }+ _ -> w++wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a+wrappedStep f dt w = updateInteractionTime (updateState w)+ where updateInteractionTime w+ | lastInteractionTime w > 5 = w+ | otherwise = w { lastInteractionTime = lastInteractionTime w + dt }+ updateState w+ | playbackSpeed w == 0 = w+ | otherwise = toState (f (dt * playbackSpeed w)) w++reportDiff :: String -> (a -> a) -> (a -> a)+reportDiff msg f x = unsafePerformIO $ do+ a <- makeStableName $! x+ b <- makeStableName $! r+ when (a /= b) $ debugLog $ msg ++ ": reportDiff found a diff"+ return r+ where r = f x++wrappedEvent :: forall a . + (Wrapped a -> [Control a])+ -> (Double -> a -> a)+ -> (Event -> a -> a)+ -> Event+ -> Wrapped a+ -> Wrapped a+wrappedEvent _ _ eventHandler (TimePassing dt) w+ | playbackSpeed w == 0 = w+ | otherwise = toState (eventHandler (TimePassing (dt * playbackSpeed w))) w+wrappedEvent ctrls stepHandler eventHandler event w+ | playbackSpeed w == 0 || handled = afterControls {lastInteractionTime = 0}+ | otherwise = toState (eventHandler (adaptEvent event)) afterControls {lastInteractionTime = 0}+ where+ (afterControls, handled) = foldr stepFunction (w, False) (ctrls w)++ stepFunction control (world, True) = (world, True)+ stepFunction control (world, False) = handleControl fullStep event control world++ fullStep dt = stepHandler dt . eventHandler (TimePassing dt)++ adaptEvent (PointerMovement p) = PointerMovement (adaptPoint p)+ adaptEvent (PointerPress p) = PointerPress (adaptPoint p)+ adaptEvent (PointerRelease p) = PointerRelease (adaptPoint p)+ adaptEvent other = other++ adaptPoint (x, y) = (x / k - dx, y / k - dy)++ (dx, dy) = panCenter w+ k = zoomFactor w++scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double+scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2++snapSlider :: Double -> [Double] -> Double -> Double+snapSlider eps targets val = foldr snap val targets+ where snap t v | abs (t - v) < eps = t+ | otherwise = v++xToPlaybackSpeed :: Double -> Double+xToPlaybackSpeed x = snapSlider 0.2 [1..4] $ scaleRange (-1.4, 1.4) (0, 5) x++playbackSpeedToX :: Double -> Double+playbackSpeedToX s = scaleRange (0, 5) (-1.4, 1.4) s++zoomIncrement = 8 ** (1/10)++yToZoomFactor :: Double -> Double+yToZoomFactor y = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) y)++zoomFactorToY :: Double -> Double+zoomFactorToY z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z)++handleControl ::+ (Double -> a -> a) -> Event -> Control a -> Wrapped a -> (Wrapped a, Bool)+handleControl _ (PointerPress (x, y)) (RestartButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = 0}, True)+handleControl _ (PointerPress (x, y)) (StartOverButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (fmap f w, True)+ where+ f (past, future) = let x:xs = reverse past in ([x], xs ++ future)+handleControl _ (PointerPress (x, y)) (PlayButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 1}, True)+handleControl _ (PointerPress (x, y)) (PauseButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = 0}, True)+handleControl _ (PointerPress (x, y)) (FastForwardButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {playbackSpeed = min 5 $ max 2 $ playbackSpeed w + 1}, True)+handleControl _ (PointerPress (x, y)) (ZoomInButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = min (zoomIncrement ** 10) (zoomFactor w * zoomIncrement)}, True)+handleControl _ (PointerPress (x, y)) (ZoomOutButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = max (zoomIncrement ** (-10)) (zoomFactor w / zoomIncrement)}, True)+handleControl _ (PointerPress (x, y)) (ResetViewButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {zoomFactor = 1, panCenter = (0, 0)}, True)+handleControl _ (PointerPress (x,y)) (BackButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 =+ (w {state = max 0 (state w - 0.1)}, True)+handleControl _ (PointerPress (x,y)) (UndoButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 =+ (fmap (\(x:xs, ys) -> (xs, x:ys)) w, True)+handleControl _ (PointerPress (x,y)) (RedoButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 =+ (fmap (\(xs, y:ys) -> (y:xs, ys)) w, True)+handleControl f (PointerPress (x, y)) (StepButton (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 0.4 = (w {state = f 0.1 (state w)}, True)+handleControl _ (PointerPress (x, y)) (SpeedSlider (cx, cy)) w+ | abs (x - cx) < 1.5 && abs (y - cy) < 0.4 = + (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = True}, True)+handleControl _ (PointerMovement (x, y)) (SpeedSlider (cx, cy)) w+ | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx)}, True)+handleControl _ (PointerRelease (x, y)) (SpeedSlider (cx, cy)) w+ | isDraggingSpeed w = (w {playbackSpeed = xToPlaybackSpeed (x - cx), isDraggingSpeed = False}, True)+handleControl _ (PointerPress (x, y)) (ZoomSlider (cx, cy)) w+ | abs (x - cx) < 0.4 && abs (y - cy) < 1.5 = + (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = True}, True)+handleControl _ (PointerMovement (x, y)) (ZoomSlider (cx, cy)) w+ | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy)}, True)+handleControl _ (PointerRelease (x, y)) (ZoomSlider (cx, cy)) w+ | isDraggingZoom w = (w {zoomFactor = yToZoomFactor (y - cy), isDraggingZoom = False}, True)+handleControl _ (PointerPress (x, y)) (HistorySlider (cx, cy)) w+ | abs (x - cx) < 2.5 && abs (y - cy) < 0.4 = + (travelToTime (x - cx) <$> w {isDraggingHistory = True}, True)+handleControl _ (PointerMovement (x, y)) (HistorySlider (cx, cy)) w+ | isDraggingHistory w = (travelToTime (x - cx) <$> w, True)+handleControl _ (PointerRelease (x, y)) (HistorySlider (cx, cy)) w+ | isDraggingHistory w = (travelToTime (x - cx) <$> w {isDraggingHistory = False}, True)+handleControl _ (PointerPress (x, y)) PanningLayer w =+ (w {panDraggingAnchor = Just (x, y)}, True)+handleControl _ (PointerMovement (x, y)) PanningLayer w+ | Just (ax, ay) <- panDraggingAnchor w+ , (px, py) <- panCenter w+ = (w { panCenter = (px + (x - ax) / zoomFactor w, py + (y - ay) / zoomFactor w),+ panDraggingAnchor = Just (x, y)+ }, True)+handleControl _ (PointerRelease (x, y)) PanningLayer w+ | Just (ax, ay) <- panDraggingAnchor w = (w {panDraggingAnchor = Nothing}, True)+handleControl _ _ _ w = (w, False)++travelToTime :: Double -> ([s],[s]) -> ([s],[s]) +travelToTime t (past, future)+ | n == 1 = (past, future)+ | otherwise = go past future (n1 - desiredN1)+ where n1 = length past+ n2 = length future+ n = n1 + n2+ desiredN1 = round (scaleRange (-2.4, 2.4) (1, fromIntegral n) t)+ go past future diff+ | diff > 0 = go (tail past) (head past : future) (diff - 1)+ | diff < 0 = go (head future : past) (tail future) (diff + 1)+ | otherwise = (past, future)++wrappedDraw ::+ (Wrapped a -> [Control a]) -> (a -> Picture) -> Wrapped a -> Picture+wrappedDraw ctrls f w = drawControlPanel ctrls w <> dilated k (translated dx dy (f (state w)))+ where (dx, dy) = panCenter w+ k = zoomFactor w++drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture+drawControlPanel ctrls w+ | alpha > 0 = pictures [drawControl w alpha c | c <- ctrls w]+ | otherwise = blank+ where+ alpha+ | lastInteractionTime w < 4.5 = 1+ | lastInteractionTime w < 5.0 = 10 - 2 * lastInteractionTime w+ | otherwise = 0++drawControl :: Wrapped a -> Double -> Control a -> Picture+drawControl _ alpha (RestartButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>+ translated 0.173 (-0.1) (solidRectangle 0.17 0.17)) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (StartOverButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>+ translated 0.173 (-0.1) (solidRectangle 0.17 0.17)) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (PlayButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 0)]) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (PauseButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated (-0.15) 0 (solidRectangle 0.2 0.6) <>+ translated 0.15 0 (solidRectangle 0.2 0.6)) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (FastForwardButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)] <>+ solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (ZoomInButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated (-0.05) (0.05) (+ thickCircle 0.1 0.22 <>+ solidRectangle 0.06 0.25 <>+ solidRectangle 0.25 0.06 <>+ rotated (-pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))+ )) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (ZoomOutButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated (-0.05) (0.05) (+ thickCircle 0.1 0.22 <>+ solidRectangle 0.25 0.06 <>+ rotated (-pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))+ )) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ _ PanningLayer = blank+drawControl _ alpha (ResetViewButton (x,y)) = translated x y p+ where+ p =+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.7 0.2) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.2 0.7) <>+ colored (RGBA 0.0 0.0 0.0 alpha) (thickRectangle 0.1 0.5 0.5) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (BackButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated 0.15 0 (solidRectangle 0.2 0.5) <>+ solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (UndoButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated 0.15 0 (solidRectangle 0.2 0.5) <>+ solidPolygon [(-0.05, 0.25), (-0.05, -0.25), (-0.3, 0)]) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (StepButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated (-0.15) 0 (solidRectangle 0.2 0.5) <>+ solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl _ alpha (RedoButton (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated (-0.15) 0 (solidRectangle 0.2 0.5) <>+ solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)+drawControl w alpha (TimeLabel (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (scaled 0.5 0.5 $ lettering (pack (showFFloatAlt (Just 4) (state w) "s"))) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)+drawControl w alpha (SpeedSlider (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated xoff 0.75 $ scaled 0.5 0.5 $+ lettering (pack (showFFloatAlt (Just 2) (playbackSpeed w) "x"))) <>+ colored (RGBA 0 0 0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.25) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.25)+ xoff = playbackSpeedToX (playbackSpeed w)+drawControl w alpha (ZoomSlider (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated (-1.1) yoff $ scaled 0.5 0.5 $+ lettering (pack (show (round (zoomFactor w * 100) :: Int) ++ "%"))) <>+ colored (RGBA 0 0 0 alpha) (translated 0 yoff (solidRectangle 0.8 0.2)) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.25 2.8) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.25 2.8)+ yoff = zoomFactorToY (zoomFactor w)+drawControl w alpha (HistorySlider (x,y)) = translated x y p+ where+ p =+ colored+ (RGBA 0 0 0 alpha)+ (translated xoff 0.75 $ scaled 0.5 0.5 $+ lettering (pack (show n1 ++ "/" ++ show (n1 + n2)))) <>+ colored (RGBA 0.0 0.0 0.0 alpha) (translated xoff 0 (solidRectangle 0.2 0.8)) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 4.8 0.25) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 4.8 0.25)+ xoff | n < 2 = 2.4+ | otherwise = scaleRange (1, fromIntegral n) (-2.4, 2.4) (fromIntegral n1)+ n1 = length (fst (state w))+ n2 = length (snd (state w))+ n = n1 + n2++drawingControls :: Wrapped () -> [Control ()]+drawingControls w+ | lastInteractionTime w > 5 = []+ | otherwise = commonControls ++ resetViewButton+ where+ commonControls = [+ PanningLayer,+ ZoomInButton (9, -4),+ ZoomOutButton (9, -8),+ ZoomSlider (9, -6)+ ]+ resetViewButton+ | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]+ | otherwise = []++drawingOf pic = runInspect drawingControls () (\_ _ -> ()) (\_ _ -> ()) (const pic)++animationControls :: Wrapped Double -> [Control Double]+animationControls w+ | lastInteractionTime w > 5 = []+ | otherwise = commonControls ++ pauseDependentControls +++ backButton ++ resetViewButton+ where+ commonControls = [+ PanningLayer,+ RestartButton (-9, -9),+ TimeLabel (8, -9),+ SpeedSlider (-3, -9),+ FastForwardButton (-1, -9),+ ZoomInButton (9, -4),+ ZoomOutButton (9, -8),+ ZoomSlider (9, -6)+ ]+ pauseDependentControls+ | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-6, -9)]+ | otherwise = [PauseButton (-8, -9)]+ backButton+ | playbackSpeed w == 0 && state w > 0 = [BackButton (-7, -9)]+ | otherwise = []+ resetViewButton+ | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]+ | otherwise = []++animationOf f = runInspect animationControls 0 (+) (\_ r -> r) f++simulationControls :: Wrapped w -> [Control w]+simulationControls w+ | lastInteractionTime w > 5 = []+ | otherwise = commonControls ++ pauseDependentControls ++ resetViewButton+ where+ commonControls = [+ PanningLayer,+ FastForwardButton (-4, -9),+ SpeedSlider (-6, -9),+ ZoomInButton (9, -4),+ ZoomOutButton (9, -8),+ ZoomSlider (9, -6)+ ]+ pauseDependentControls+ | playbackSpeed w == 0 = [PlayButton (-8, -9), StepButton (-2, -9)]+ | otherwise = [PauseButton (-8, -9)]+ resetViewButton+ | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]+ | otherwise = []++statefulDebugControls :: Wrapped ([w],[w]) -> [Control ([w],[w])]+statefulDebugControls w+ | lastInteractionTime w > 5 = []+ | otherwise = panningLayer ++ pauseDependentControls ++ commonControls +++ resetViewButton+ where + hasHistory = not (null (tail (fst (state w))))+ hasFuture = not (null (snd (state w)))+ advance | hasFuture = [RedoButton (6, -9)]+ | otherwise = [StepButton (6, -9)]+ regress | hasHistory = [UndoButton (0, -9)]+ | otherwise = []+ commonControls = [+ StartOverButton (-1, -9),+ FastForwardButton (-4, -9),+ SpeedSlider (-6, -9),+ ZoomInButton (9, -4),+ ZoomOutButton (9, -8),+ ZoomSlider (9, -6)+ ]+ pauseDependentControls+ | playbackSpeed w == 0 = + [PlayButton (-8, -9), HistorySlider (3, -9)] ++ advance ++ regress+ | otherwise = [PauseButton (-8, -9)]+ resetViewButton+ | zoomFactor w /= 1 || panCenter w /= (0,0) = [ResetViewButton (9, -3)]+ | otherwise = []+ panningLayer + | playbackSpeed w == 0 = [PanningLayer]+ | otherwise = []++simulationOf initial step draw =+ runInspect simulationControls initial step (\_ r -> r) draw++prependIfChanged :: (a -> a) -> ([a],[a]) -> ([a],[a])+prependIfChanged f (x:xs, ys) =+ case x `seq` x' `seq` (reallyUnsafePtrEquality# x x') of+ 0# -> (x' : x : xs, [])+ _ -> (x : xs, ys)+ where x' = f x++debugSimulationOf initial simStep simDraw =+ runInspect statefulDebugControls ([initial],[]) step (\_ r -> r) draw+ where+ step dt = prependIfChanged (simStep dt)+ draw (x:_, _) = simDraw x++debugInteractionOf initial baseStep baseEvent baseDraw = + runInspect statefulDebugControls ([initial], []) step event draw + where+ step dt = prependIfChanged (baseStep dt)+ event e = prependIfChanged (baseEvent e)+ draw (x:_, _) = baseDraw x debugActivityOf initial change picture = debugInteractionOf initial (const id) change picture
src/CodeWorld/Event.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -58,34 +58,8 @@ data Event = KeyPress !Text | KeyRelease !Text- | MousePress !MouseButton- !Point- | MouseRelease !MouseButton- !Point- | MouseMovement !Point+ | PointerPress !Point+ | PointerRelease !Point+ | PointerMovement !Point | TimePassing !Double 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--{-# WARNING MousePress ["Please use PointerPress instead of MousePress.",- "MousePress may be removed July 2019." ] #-}-{-# WARNING MouseRelease ["Please use PointerRelease instead of MouseRelease.",- "MouseRelease may be removed July 2019."] #-}-{-# WARNING MouseMovement ["Please use PointerMovement instead of MouseMovement.",- "MouseMovement may be removed July 2019."] #-}-{-# WARNING MouseButton ["Please use pointer events, which don't have buttons.",- "MouseButton may be removed July 2019."] #-}
src/CodeWorld/Picture.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-- Copyright 2018 The CodeWorld Authors. All rights reserved.+ Copyright 2019 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -62,96 +62,89 @@ dotProduct :: Vector -> Vector -> Double dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 -getDebugSrcLoc :: CallStack -> SrcLoc-getDebugSrcLoc cs =- case Data.List.find ((== "main") . srcLocPackage) locs of- Just loc -> loc- Nothing -> error "Cannot find debug source location."- where- locs = map snd (getCallStack cs)- data Picture- = SolidPolygon SrcLoc+ = SolidPolygon (Maybe SrcLoc) [Point]- | SolidClosedCurve SrcLoc+ | SolidClosedCurve (Maybe SrcLoc) [Point]- | Polygon SrcLoc+ | Polygon (Maybe SrcLoc) [Point]- | ThickPolygon SrcLoc+ | ThickPolygon (Maybe SrcLoc) [Point] !Double- | Rectangle SrcLoc+ | Rectangle (Maybe SrcLoc) !Double !Double- | SolidRectangle SrcLoc+ | SolidRectangle (Maybe SrcLoc) !Double !Double- | ThickRectangle SrcLoc+ | ThickRectangle (Maybe SrcLoc) !Double !Double !Double- | ClosedCurve SrcLoc+ | ClosedCurve (Maybe SrcLoc) [Point]- | ThickClosedCurve SrcLoc+ | ThickClosedCurve (Maybe SrcLoc) [Point] !Double- | Polyline SrcLoc+ | Polyline (Maybe SrcLoc) [Point]- | ThickPolyline SrcLoc+ | ThickPolyline (Maybe SrcLoc) [Point] !Double- | Curve SrcLoc+ | Curve (Maybe SrcLoc) [Point]- | ThickCurve SrcLoc+ | ThickCurve (Maybe SrcLoc) [Point] !Double- | Circle SrcLoc+ | Circle (Maybe SrcLoc) !Double- | SolidCircle SrcLoc+ | SolidCircle (Maybe SrcLoc) !Double- | ThickCircle SrcLoc+ | ThickCircle (Maybe SrcLoc) !Double !Double- | Sector SrcLoc+ | Sector (Maybe SrcLoc) !Double !Double !Double- | Arc SrcLoc+ | Arc (Maybe SrcLoc) !Double !Double !Double- | ThickArc SrcLoc+ | ThickArc (Maybe SrcLoc) !Double !Double !Double !Double- | StyledLettering SrcLoc+ | StyledLettering (Maybe SrcLoc) !TextStyle !Font !Text- | Lettering SrcLoc+ | Lettering (Maybe SrcLoc) !Text- | Color SrcLoc+ | Color (Maybe SrcLoc) !Color !Picture- | Translate SrcLoc+ | Translate (Maybe SrcLoc) !Double !Double !Picture- | Scale SrcLoc+ | Scale (Maybe SrcLoc) !Double !Double !Picture- | Dilate SrcLoc+ | Dilate (Maybe SrcLoc) !Double !Picture- | Rotate SrcLoc+ | Rotate (Maybe SrcLoc) !Double !Picture- | CoordinatePlane SrcLoc- | Logo SrcLoc- | Pictures [Picture]- | Blank SrcLoc+ | CoordinatePlane (Maybe SrcLoc)+ | Logo (Maybe SrcLoc)+ | Pictures (Maybe SrcLoc) [Picture]+ | PictureAnd (Maybe SrcLoc) [Picture]+ | Blank (Maybe SrcLoc) data TextStyle = Plain@@ -276,6 +269,9 @@ text :: HasCallStack => Text -> Picture text = Lettering (getDebugSrcLoc callStack) +{-# WARNING text ["Please used lettering instead of text.",+ "text may be removed July 2019."] #-}+ -- | A rendering of text characters. lettering :: HasCallStack => Text -> Picture lettering = Lettering (getDebugSrcLoc callStack)@@ -284,6 +280,9 @@ styledText :: HasCallStack => TextStyle -> Font -> Text -> Picture styledText = StyledLettering (getDebugSrcLoc callStack) +{-# WARNING styledText ["Please used styledLettering instead of styledText.",+ "styledText may be removed July 2019."] #-}+ -- | A rendering of text characters onto a Picture, with a specific -- choice of font and style. styledLettering :: HasCallStack => TextStyle -> Font -> Text -> Picture@@ -316,29 +315,30 @@ rotated = Rotate (getDebugSrcLoc callStack) -- A picture made by drawing these pictures, ordered from top to bottom.-pictures :: [Picture] -> Picture-pictures = Pictures--#if MIN_VERSION_base(4,11,0)+pictures :: HasCallStack => [Picture] -> Picture+pictures = Pictures (getDebugSrcLoc callStack) -instance Semigroup Picture where- a <> (Pictures bs) = Pictures (a : bs)- a <> b = Pictures [a, b]+-- | Binary composition of pictures.+(&) :: HasCallStack => Picture -> Picture -> Picture+infixr 0 & -#endif+a & b@(PictureAnd loc2 bs)+ | srcContains loc1 loc2 = PictureAnd loc1 (a:bs)+ where loc1 = getDebugSrcLoc callStack+a & b = PictureAnd (getDebugSrcLoc callStack) [a, b] instance Monoid Picture where mempty = blank- mappend a (Pictures bs) = Pictures (a : bs)- mappend a b = Pictures [a, b]+ mappend = (&) mconcat = pictures --- | Binary composition of pictures.-(&) :: Picture -> Picture -> Picture-infixr 0 &+#if MIN_VERSION_base(4,11,0) -(&) = mappend+instance Semigroup Picture where+ (<>) = (&) +#endif+ -- | A coordinate plane. Adding this to your pictures can help you measure distances -- more accurately. --@@ -352,3 +352,18 @@ -- | The CodeWorld logo. codeWorldLogo :: HasCallStack => Picture codeWorldLogo = Logo (getDebugSrcLoc callStack)++getDebugSrcLoc :: CallStack -> Maybe SrcLoc+getDebugSrcLoc cs = Data.List.find ((== "main") . srcLocPackage) locs+ where+ locs = map snd (getCallStack cs)++srcContains :: Maybe SrcLoc -> Maybe SrcLoc -> Bool+srcContains Nothing _ = False+srcContains _ Nothing = True+srcContains (Just a) (Just b) =+ srcLocFile a == srcLocFile b && srcLocStartLine a < srcLocStartLine b ||+ (srcLocStartLine a == srcLocStartLine b &&+ srcLocStartCol a <= srcLocStartCol b) &&+ srcLocEndLine a > srcLocEndLine b ||+ (srcLocEndLine a == srcLocEndLine b && srcLocEndCol a >= srcLocEndCol b)