diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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. diff --git a/codeworld-api.cabal b/codeworld-api.cabal --- a/codeworld-api.cabal +++ b/codeworld-api.cabal @@ -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 -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, diff --git a/jsbits/sim_fp.js b/jsbits/sim_fp.js new file mode 100644 --- /dev/null +++ b/jsbits/sim_fp.js @@ -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); + } +} diff --git a/src/CodeWorld.hs b/src/CodeWorld.hs --- a/src/CodeWorld.hs +++ b/src/CodeWorld.hs @@ -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 diff --git a/src/CodeWorld/App.hs b/src/CodeWorld/App.hs --- a/src/CodeWorld/App.hs +++ b/src/CodeWorld/App.hs @@ -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. diff --git a/src/CodeWorld/App2.hs b/src/CodeWorld/App2.hs --- a/src/CodeWorld/App2.hs +++ b/src/CodeWorld/App2.hs @@ -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. diff --git a/src/CodeWorld/CanvasM.hs b/src/CodeWorld/CanvasM.hs --- a/src/CodeWorld/CanvasM.hs +++ b/src/CodeWorld/CanvasM.hs @@ -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 diff --git a/src/CodeWorld/CollaborationUI.hs b/src/CodeWorld/CollaborationUI.hs --- a/src/CodeWorld/CollaborationUI.hs +++ b/src/CodeWorld/CollaborationUI.hs @@ -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 diff --git a/src/CodeWorld/Color.hs b/src/CodeWorld/Color.hs --- a/src/CodeWorld/Color.hs +++ b/src/CodeWorld/Color.hs @@ -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." ] #-} diff --git a/src/CodeWorld/Driver.hs b/src/CodeWorld/Driver.hs --- a/src/CodeWorld/Driver.hs +++ b/src/CodeWorld/Driver.hs @@ -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 diff --git a/src/CodeWorld/Event.hs b/src/CodeWorld/Event.hs --- a/src/CodeWorld/Event.hs +++ b/src/CodeWorld/Event.hs @@ -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."] #-} diff --git a/src/CodeWorld/Picture.hs b/src/CodeWorld/Picture.hs --- a/src/CodeWorld/Picture.hs +++ b/src/CodeWorld/Picture.hs @@ -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)