codeworld-api (empty) → 0.1.0.1
raw patch · 8 files changed
+1775/−0 lines, 8 filesdep +basedep +blank-canvasdep +ghcjs-basesetup-changed
Dependencies added: base, blank-canvas, ghcjs-base, ghcjs-dom, mtl, random, text, time
Files
- LICENSE +202/−0
- Setup.hs +18/−0
- codeworld-api.cabal +41/−0
- src/CodeWorld.hs +121/−0
- src/CodeWorld/Color.hs +133/−0
- src/CodeWorld/Driver.hs +958/−0
- src/CodeWorld/Event.hs +64/−0
- src/CodeWorld/Picture.hs +238/−0
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ 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.
+ Setup.hs view
@@ -0,0 +1,18 @@+{-+ Copyright 2016 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++import Distribution.Simple+main = defaultMain
+ codeworld-api.cabal view
@@ -0,0 +1,41 @@+Name: codeworld-api+Version: 0.1.0.1+Synopsis: Graphics library for CodeWorld+License: Apache+License-file: LICENSE+Author: The CodeWorld Authors+Maintainer: Chris Smith <cdsmith@gmail.com>+Copyright: (c) 2016, The CodeWorld Authors+Build-type: Simple+Cabal-version: >=1.8++Description:+ This module provides the drawing code for CodeWorld. It is heavily inspired by+ Gloss, but modified for consistency and pedagogical reasons.+ .+ It comes with two backends. When compiled with GHCJS, it uses the JavaScript FFI to+ run on <http://code.world/>. When compiled with GHC, it uses the blank-canvas+ package to provide a webpage consisting of just a panel locally. This way, the same+ program that runs on the CodeWorld server can also be run locally.++Library+ Hs-source-dirs: src+ Exposed-modules: CodeWorld+ Other-modules: CodeWorld.Color,+ CodeWorld.Picture,+ CodeWorld.Event,+ CodeWorld.Driver+ Build-depends: base < 5,+ mtl,+ random,+ text,+ time+ if impl(ghcjs)+ Build-depends:+ ghcjs-base,+ ghcjs-dom+ else+ Build-depends: blank-canvas++ Exposed: True+ Ghc-options: -O2
+ src/CodeWorld.hs view
@@ -0,0 +1,121 @@+{-+ Copyright 2016 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++module CodeWorld (+ -- * Entry points+ drawingOf,+ pictureOf,+ animationOf,+ simulationOf,+ interactionOf,++ -- * Pictures+ Picture,+ TextStyle(..),+ Font(..),+ blank,+ line,+ thickLine,+ path,+ thickPath,+ polygon,+ thickPolygon,+ solidPolygon,+ curve,+ thickCurve,+ loop,+ thickLoop,+ solidLoop,+ rectangle,+ solidRectangle,+ thickRectangle,+ circle,+ solidCircle,+ thickCircle,+ arc,+ sector,+ thickArc,+ text,+ styledText,+ colored,+ coloured,+ translated,+ scaled,+ dilated,+ rotated,+ pictures,+ (&),+ (<>),+ coordinatePlane,+ codeWorldLogo,+ Point,+ Vector,+ vectorSum,+ vectorDifference,+ scaledVector,+ rotatedVector,+ dotProduct,++ -- * Colors+ Color(..),+ Colour,+ black,+ white,+ red,+ green,+ blue,+ cyan,+ magenta,+ yellow,+ aquamarine,+ orange,+ azure,+ violet,+ chartreuse,+ rose,+ brown,+ pink,+ purple,+ gray,+ grey,+ mixed,+ lighter,+ light,+ darker,+ dark,+ brighter,+ bright,+ duller,+ dull,+ translucent,+ hue,+ saturation,+ luminosity,+ fromHSL,++ -- * Events+ Event(..),+ MouseButton(..),++ -- * Debugging+ trace+ ) where++import CodeWorld.Color+import CodeWorld.Picture+import CodeWorld.Event+import CodeWorld.Driver+import Data.Monoid
+ src/CodeWorld/Color.hs view
@@ -0,0 +1,133 @@+{-+ Copyright 2016 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++module CodeWorld.Color where++data Color = RGBA !Double !Double !Double !Double deriving (Show, Eq)+type Colour = Color++white, black :: Color+white = RGBA 1 1 1 1+black = RGBA 0 0 0 1++-- Primary and secondary colors+red, green, blue, cyan, magenta, yellow :: Color+red = fromHSL (0/3 * pi) 0.75 0.5+yellow = fromHSL (1/3 * pi) 0.75 0.5+green = fromHSL (2/3 * pi) 0.75 0.5+cyan = fromHSL (3/3 * pi) 0.75 0.5+blue = fromHSL (4/3 * pi) 0.75 0.5+magenta = fromHSL (5/3 * pi) 0.75 0.5++-- Tertiary colors+orange, rose, chartreuse, aquamarine, violet, azure :: Color+orange = fromHSL ( 1/6 * pi) 0.75 0.5+chartreuse = fromHSL ( 3/6 * pi) 0.75 0.5+aquamarine = fromHSL ( 5/6 * pi) 0.75 0.5+azure = fromHSL ( 7/6 * pi) 0.75 0.5+violet = fromHSL ( 9/6 * pi) 0.75 0.5+rose = fromHSL (11/6 * pi) 0.75 0.5++-- Other common colors and color names+brown = fromHSL (1/6 * pi) 0.5 0.5+purple = fromHSL (1.556 * pi) 0.75 0.5+pink = fromHSL (23/12 * pi) 0.75 0.75++mixed :: Color -> Color -> Color+mixed (RGBA r1 g1 b1 a1) (RGBA r2 g2 b2 a2)+ | a1 + a2 == 0 = RGBA 0 0 0 0+ | otherwise = RGBA r g b a+ where r = sqrt(r1^2 * a1 + r2^2 * a2 / (a1 + a2))+ g = sqrt(g1^2 * a1 + g2^2 * a2 / (a1 + a2))+ b = sqrt(b1^2 * a1 + b2^2 * a2 / (a1 + a2))+ a = (a1 + a2) / 2++-- Helper function that sets the alpha of the second color to that+-- of the first+sameAlpha :: Color -> Color -> Color+sameAlpha (RGBA r1 g1 b1 a1) (RGBA r2 g2 b2 a2) = RGBA r2 g2 b2 a1++lighter :: Double -> Color -> Color+lighter d c = sameAlpha c $ fromHSL (hue c) (saturation c) (fence (luminosity c + d))+ where fence x = max 0 (min 1 x)++light :: Color -> Color+light = lighter 0.15++darker :: Double -> Color -> Color+darker d = lighter (-d)++dark :: Color -> Color+dark = darker 0.15++brighter :: Double -> Color -> Color+brighter d c = sameAlpha c $ fromHSL (hue c) (fence (saturation c + d)) (luminosity c)+ where fence x = max 0 (min 1 x)++bright :: Color -> Color+bright = brighter 0.25++duller :: Double -> Color -> Color+duller d = brighter (-d)++dull :: Color -> Color+dull = duller 0.25++translucent :: Color -> Color+translucent (RGBA r g b a) = RGBA r g b (a/2)++gray, grey :: Double -> Color+gray = grey+grey k = RGBA k k k 1++hue :: Color -> Double+hue (RGBA r g b a)+ | hi == lo = 0+ | r == hi && g >= b = (g - b) / (hi - lo) * pi / 3+ | r == hi = (g - b) / (hi - lo) * pi / 3 + 2 * pi+ | g == hi = (b - r) / (hi - lo) * pi / 3 + 2/3 * pi+ | otherwise = (r - g) / (hi - lo) * pi / 3 + 4/3 * pi+ where hi = max r (max g b)+ lo = min r (min g b)++saturation :: Color -> Double+saturation (RGBA r g b a)+ | hi == lo = 0+ | otherwise = (hi - lo) / (1 - abs (hi + lo - 1))+ where hi = max r (max g b)+ lo = min r (min g b)++luminosity :: Color -> Double+luminosity (RGBA r g b a) = (lo + hi) / 2+ where hi = max r (max g b)+ lo = min r (min g b)++-- Based on the algorithm from the CSS3 specification.+fromHSL :: Double -> Double -> Double -> Color+fromHSL h s l = RGBA r g b 1+ where m1 = l * 2 - m2+ m2 | l <= 0.5 = l * (s + 1)+ | otherwise = l + s - l * s+ r = convert m1 m2 (h / 2 / pi + 1/3)+ g = convert m1 m2 (h / 2 / pi )+ b = convert m1 m2 (h / 2 / pi - 1/3)+ convert m1 m2 h+ | h < 0 = convert m1 m2 (h + 1)+ | h > 1 = convert m1 m2 (h - 1)+ | h * 6 < 1 = m1 + (m2 - m1) * h * 6+ | h * 2 < 1 = m2+ | h * 3 < 2 = m1 + (m2 - m1) * (2/3 - h) * 6+ | otherwise = m1
+ src/CodeWorld/Driver.hs view
@@ -0,0 +1,958 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PatternGuards #-}++{-+ Copyright 2016 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++module CodeWorld.Driver (+ drawingOf,+ pictureOf,+ animationOf,+ simulationOf,+ interactionOf,+ trace+ ) where+++import CodeWorld.Color+import CodeWorld.Event+import CodeWorld.Picture+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Control.Monad.Trans (liftIO)+import Data.Char (chr)+import Data.List (zip4)+import Data.Maybe (mapMaybe)+import Data.Monoid+import qualified Data.Text as T+import Data.Text (Text, singleton, pack)+import Numeric++#ifdef ghcjs_HOST_OS++import Data.IORef+import Data.JSString.Text+import Data.Time.Clock+import Data.Word+import GHCJS.DOM+import GHCJS.DOM.Window as Window+import GHCJS.DOM.Document+import qualified GHCJS.DOM.ClientRect as ClientRect+import GHCJS.DOM.Element+import GHCJS.DOM.EventM+import GHCJS.DOM.MouseEvent+import GHCJS.DOM.Types (Element, unElement)+import GHCJS.Foreign+import GHCJS.Marshal.Pure+import GHCJS.Types+import JavaScript.Web.AnimationFrame+import qualified JavaScript.Web.Canvas as Canvas+import qualified JavaScript.Web.Canvas.Internal as Canvas+import System.IO.Unsafe+import System.Random++#else++import Data.Time.Clock+import qualified Debug.Trace+import qualified Graphics.Blank as Canvas+import Graphics.Blank (Canvas)+import System.IO+import Text.Printf++#endif+++--------------------------------------------------------------------------------+-- The common interface, provided by both implementations below.++-- | Draws a `Picture`. This is the simplest CodeWorld entry point.+drawingOf :: Picture -> IO ()++-- | Draws a `Picture`. This is the simplest CodeWorld entry point.+pictureOf :: Picture -> IO ()+{-# WARNING pictureOf "Please use drawingOf instead of pictureOf" #-}++-- | Shows an animation, with a picture for each time given by the parameter.+animationOf :: (Double -> Picture) -> IO ()++-- | Shows a simulation, which is essentially a continuous-time dynamical+-- system described by an initial value and step function.+simulationOf :: world -> (Double -> world -> world) -> (world -> Picture) -> IO ()++-- | Runs an interactive event-driven CodeWorld program. This is the most+-- advanced CodeWorld entry point.+interactionOf :: world+ -> (Double -> world -> world)+ -> (Event -> world -> world)+ -> (world -> Picture)+ -> IO ()++-- | Prints a debug message to the CodeWorld console when a value is forced.+-- This is equivalent to the similarly named function in `Debug.Trace`, except+-- that it uses the CodeWorld console instead of standard output.+trace :: Text -> a -> a++++--------------------------------------------------------------------------------+-- Draw state. An affine transformation matrix, plus a Bool indicating whether+-- a color has been chosen yet.++type DrawState = (Double, Double, Double, Double, Double, Double, Maybe Color)++initialDS :: DrawState+initialDS = (1, 0, 0, 1, 0, 0, Nothing)++translateDS :: Double -> Double -> DrawState -> DrawState+translateDS x y (a,b,c,d,e,f,hc) =+ (a, b, c, d, a*25*x + c*25*y + e, b*25*x + d*25*y + f, hc)++scaleDS :: Double -> Double -> DrawState -> DrawState+scaleDS x y (a,b,c,d,e,f,hc) =+ (x*a, x*b, y*c, y*d, e, f, hc)++rotateDS :: Double -> DrawState -> DrawState+rotateDS r (a,b,c,d,e,f,hc) =+ (a * cos r + c * sin r,+ b * cos r + d * sin r,+ c * cos r - a * sin r,+ d * cos r - b * sin r,+ e, f, hc)++setColorDS :: Color -> DrawState -> DrawState+setColorDS col (a,b,c,d,e,f,Nothing) = (a,b,c,d,e,f,Just col)+setColorDS _ (a,b,c,d,e,f,Just col) = (a,b,c,d,e,f,Just col)++getColorDS :: DrawState -> Maybe Color+getColorDS (a,b,c,d,e,f,col) = col++--------------------------------------------------------------------------------+-- GHCJS implementation of drawing++#ifdef ghcjs_HOST_OS++foreign import javascript unsafe "$1.drawImage($2, $3, $4, $5, $6);"+ js_canvasDrawImage :: Canvas.Context -> Element -> Int -> Int -> Int -> Int -> IO ()++foreign import javascript unsafe "$1.getContext('2d', { alpha: false })"+ js_getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context++canvasFromElement :: Element -> Canvas.Canvas+canvasFromElement = Canvas.Canvas . unElement++elementFromCanvas :: Canvas.Canvas -> Element+elementFromCanvas = pFromJSVal . jsval+++withDS :: Canvas.Context -> DrawState -> IO () -> IO ()+withDS ctx (ta,tb,tc,td,te,tf,col) action = do+ Canvas.save ctx+ Canvas.transform ta tb tc td te tf ctx+ Canvas.beginPath ctx+ action+ Canvas.restore ctx++applyColor :: Canvas.Context -> DrawState -> IO ()+applyColor ctx ds = case getColorDS ds of+ Nothing -> do+ Canvas.strokeStyle 0 0 0 1 ctx+ Canvas.fillStyle 0 0 0 1 ctx+ Just (RGBA r g b a) -> do+ Canvas.strokeStyle (round $ r * 255)+ (round $ g * 255)+ (round $ b * 255)+ a ctx+ Canvas.fillStyle (round $ r * 255)+ (round $ g * 255)+ (round $ b * 255)+ a ctx++foreign import javascript unsafe "$1.globalCompositeOperation = $2"+ js_setGlobalCompositeOperation :: Canvas.Context -> JSString -> IO ()++drawCodeWorldLogo :: Canvas.Context -> DrawState -> Int -> Int -> Int -> Int -> IO ()+drawCodeWorldLogo ctx ds x y w h = do+ Just doc <- currentDocument+ Just canvas <- getElementById doc ("cwlogo" :: JSString)+ case getColorDS ds of+ Nothing -> js_canvasDrawImage ctx canvas x y w h+ Just (RGBA r g b a) -> do+ -- This is a tough case. The best we can do is to allocate an+ -- offscreen buffer as a temporary.+ buf <- Canvas.create w h+ bufctx <- js_getCodeWorldContext buf+ applyColor bufctx ds+ Canvas.fillRect 0 0 (fromIntegral w) (fromIntegral h) bufctx+ js_setGlobalCompositeOperation bufctx "destination-in"+ js_canvasDrawImage bufctx canvas 0 0 w h+ js_canvasDrawImage ctx (elementFromCanvas buf) x y w h++followPath :: Canvas.Context -> [Point] -> Bool -> Bool -> IO ()+followPath ctx [] closed _ = return ()+followPath ctx [p1] closed _ = return ()+followPath ctx ((sx,sy):ps) closed False = do+ Canvas.moveTo (25 * sx) (25 * sy) ctx+ forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x) (25 * y) ctx+ when closed $ Canvas.closePath ctx+followPath ctx [p1, p2] False True = followPath ctx [p1, p2] False False+followPath ctx ps False True = do+ let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps+ dprev = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ dnext = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ p = dprev / (dprev + dnext)+ cx = x2 + p * (x1 - x3) / 2+ cy = y2 + p * (y1 - y3) / 2+ in do Canvas.moveTo (25 * x1) (25 * y1) ctx+ Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x2) (25 * y2) ctx+ forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $+ \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->+ let dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ d2 = sqrt ((x4 - x3)^2 + (y4 - y3)^2)+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ in Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)+ (25 * x3) (25 * y3) ctx+ let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps+ dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ r = d1 / (dp + d1)+ cx = x2 + r * (x3 - x1) / 2+ cy = y2 + r * (y3 - y1) / 2+ in Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x3) (25 * y3) ctx+followPath ctx ps@(_:(sx,sy):_) True True = do+ Canvas.moveTo (25 * sx) (25 * sy) ctx+ let rep = cycle ps+ forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $+ \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->+ let dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ d2 = sqrt ((x4 - x3)^2 + (y4 - y3)^2)+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ in Canvas.bezierCurveTo (25 * cx1) (25 * cy1) (25 * cx2) (25 * cy2)+ (25 * x3) (25 * y3) ctx+ Canvas.closePath ctx++drawFigure :: Canvas.Context -> DrawState -> Double -> IO () -> IO ()+drawFigure ctx ds w figure = do+ withDS ctx ds $ do+ figure+ when (w /= 0) $ do+ Canvas.lineWidth (25 * w) ctx+ applyColor ctx ds+ Canvas.stroke ctx+ when (w == 0) $ do+ Canvas.lineWidth 1 ctx+ applyColor ctx ds+ Canvas.stroke ctx++fontString :: TextStyle -> Font -> JSString+fontString style font = stylePrefix style <> "25px " <> fontName font+ where stylePrefix Plain = ""+ stylePrefix Bold = "bold "+ stylePrefix Italic = "italic "+ fontName SansSerif = "sans-serif"+ fontName Serif = "serif"+ fontName Monospace = "monospace"+ fontName Handwriting = "cursive"+ fontName Fancy = "fantasy"+ fontName (NamedFont txt) = "\"" <> textToJSString (T.filter (/= '"') txt) <> "\""++drawPicture :: Canvas.Context -> DrawState -> Picture -> IO ()+drawPicture ctx ds (Polygon ps smooth) = do+ withDS ctx ds $ followPath ctx ps True smooth+ applyColor ctx ds+ Canvas.fill ctx+drawPicture ctx ds (Path ps w closed smooth) = do+ drawFigure ctx ds w $ followPath ctx ps closed smooth+drawPicture ctx ds (Sector b e r) = withDS ctx ds $ do+ Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx+ Canvas.lineTo 0 0 ctx+ applyColor ctx ds+ Canvas.fill ctx+drawPicture ctx ds (Arc b e r w) = do+ drawFigure ctx ds w $ do+ Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx+drawPicture ctx ds (Text sty fnt txt) = withDS ctx ds $ do+ Canvas.scale 1 (-1) ctx+ applyColor ctx ds+ Canvas.font (fontString sty fnt) ctx+ Canvas.fillText (textToJSString txt) 0 0 ctx+drawPicture ctx ds Logo = withDS ctx ds $ do+ Canvas.scale 1 (-1) ctx+ drawCodeWorldLogo ctx ds (-225) (-50) 450 100+drawPicture ctx ds (Color col p) = drawPicture ctx (setColorDS col ds) p+drawPicture ctx ds (Translate x y p) = drawPicture ctx (translateDS x y ds) p+drawPicture ctx ds (Scale x y p) = drawPicture ctx (scaleDS x y ds) p+drawPicture ctx ds (Rotate r p) = drawPicture ctx (rotateDS r ds) p+drawPicture ctx ds (Pictures ps) = mapM_ (drawPicture ctx ds) (reverse ps)++drawFrame :: Canvas.Context -> Picture -> IO ()+drawFrame ctx pic = do+ Canvas.fillStyle 255 255 255 1 ctx+ Canvas.fillRect (-250) (-250) 500 500 ctx+ drawPicture ctx initialDS pic++setupScreenContext :: Element -> ClientRect.ClientRect -> IO Canvas.Context+setupScreenContext canvas rect = do+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect+ ctx <- js_getCodeWorldContext (canvasFromElement canvas)+ Canvas.save ctx+ Canvas.translate (realToFrac cw / 2) (realToFrac ch / 2) ctx+ Canvas.scale (realToFrac cw / 500) (- realToFrac ch / 500) ctx+ Canvas.lineWidth 0 ctx+ Canvas.textAlign Canvas.Center ctx+ Canvas.textBaseline Canvas.Middle ctx+ return ctx++setCanvasSize :: Element -> Element -> IO ()+setCanvasSize target canvas = do+ Just rect <- getBoundingClientRect canvas+ cx <- ClientRect.getWidth rect+ cy <- ClientRect.getHeight rect+ setAttribute target ("width" :: JSString) (show (round cx))+ setAttribute target ("height" :: JSString) (show (round cy))++display :: Picture -> IO ()+display pic = do+ Just window <- currentWindow+ Just doc <- currentDocument+ Just canvas <- getElementById doc ("screen" :: JSString)+ on window Window.resize $ liftIO (draw canvas)+ draw canvas+ where+ draw canvas = do+ setCanvasSize canvas canvas+ Just rect <- getBoundingClientRect canvas+ ctx <- setupScreenContext canvas rect+ drawFrame ctx pic+ Canvas.restore ctx++drawingOf pic = display pic `catch` reportError++pictureOf pic = display pic `catch` reportError+++--------------------------------------------------------------------------------+-- Stand-alone implementation of drawing++#else++withDS :: DrawState -> Canvas () -> Canvas ()+withDS (ta,tb,tc,td,te,tf,col) action =+ Canvas.saveRestore $ do+ Canvas.transform (ta, tb, tc, td, te, tf)+ Canvas.beginPath ()+ action++applyColor :: DrawState -> Canvas ()+applyColor ds = case getColorDS ds of+ Nothing -> do+ Canvas.strokeStyle "black"+ Canvas.fillStyle "black"+ Just (RGBA r g b a) -> do+ let style = pack $ printf "rgba(%.0f,%.0f,%.0f,%f)" (r*255) (g*255) (b*255) a+ Canvas.strokeStyle style+ Canvas.fillStyle style+++drawFigure :: DrawState -> Double -> Canvas () -> Canvas ()+drawFigure ds w figure = do+ withDS ds $ do+ figure+ when (w /= 0) $ do+ Canvas.lineWidth (25 * w)+ applyColor ds+ Canvas.stroke ()+ when (w == 0) $ do+ Canvas.lineWidth 1+ applyColor ds+ Canvas.stroke ()++followPath :: [Point] -> Bool -> Bool -> Canvas ()+followPath [] closed _ = return ()+followPath [p1] closed _ = return ()+followPath ((sx,sy):ps) closed False = do+ Canvas.moveTo (25 * sx, 25 * sy)+ forM_ ps $ \(x,y) -> Canvas.lineTo (25 * x, 25 * y)+ when closed $ Canvas.closePath ()+followPath [p1, p2] False True = followPath [p1, p2] False False+followPath ps False True = do+ let [(x1,y1), (x2,y2), (x3,y3)] = take 3 ps+ dprev = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ dnext = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ p = dprev / (dprev + dnext)+ cx = x2 + p * (x1 - x3) / 2+ cy = y2 + p * (y1 - y3) / 2+ in do Canvas.moveTo (25 * x1, 25 * y1)+ Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x2, 25 * y2)+ forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $+ \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->+ let dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ d2 = sqrt ((x4 - x3)^2 + (y4 - y3)^2)+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ in Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2+ , 25 * x3, 25 * y3)+ let [(x1,y1), (x2,y2), (x3,y3)] = reverse $ take 3 $ reverse ps+ dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ r = d1 / (dp + d1)+ cx = x2 + r * (x3 - x1) / 2+ cy = y2 + r * (y3 - y1) / 2+ in Canvas.quadraticCurveTo (25 * cx, 25 * cy, 25 * x3, 25 * y3)+followPath ps@(_:(sx,sy):_) True True = do+ Canvas.moveTo (25 * sx, 25 * sy)+ let rep = cycle ps+ forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $+ \((x1,y1),(x2,y2),(x3,y3),(x4,y4)) ->+ let dp = sqrt ((x2 - x1)^2 + (y2 - y1)^2)+ d1 = sqrt ((x3 - x2)^2 + (y3 - y2)^2)+ d2 = sqrt ((x4 - x3)^2 + (y4 - y3)^2)+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ in Canvas.bezierCurveTo ( 25 * cx1, 25 * cy1, 25 * cx2, 25 * cy2+ , 25 * x3, 25 * y3)+ Canvas.closePath ()+++fontString :: TextStyle -> Font -> Text+fontString style font = stylePrefix style <> "25px " <> fontName font+ where stylePrefix Plain = ""+ stylePrefix Bold = "bold "+ stylePrefix Italic = "italic "+ fontName SansSerif = "sans-serif"+ fontName Serif = "serif"+ fontName Monospace = "monospace"+ fontName Handwriting = "cursive"+ fontName Fancy = "fantasy"+ fontName (NamedFont txt) = "\"" <> T.filter (/= '"') txt <> "\""++drawPicture :: DrawState -> Picture -> Canvas ()+drawPicture ds (Polygon ps smooth) = do+ withDS ds $ followPath ps True smooth+ applyColor ds+ Canvas.fill ()+drawPicture ds (Path ps w closed smooth) = do+ drawFigure ds w $ followPath ps closed smooth+drawPicture ds (Sector b e r) = withDS ds $ do+ Canvas.arc (0, 0, 25 * abs r, b, e, b > e)+ Canvas.lineTo (0, 0)+ applyColor ds+ Canvas.fill ()+drawPicture ds (Arc b e r w) = do+ drawFigure ds w $ do+ Canvas.arc (0, 0, 25 * abs r, b, e, b > e)+drawPicture ds (Text sty fnt txt) = withDS ds $ do+ Canvas.scale (1, -1)+ applyColor ds+ Canvas.font (fontString sty fnt)+ Canvas.fillText (txt, 0, 0)+drawPicture ds Logo = return () -- Unimplemented+drawPicture ds (Color col p) = drawPicture (setColorDS col ds) p+drawPicture ds (Translate x y p) = drawPicture (translateDS x y ds) p+drawPicture ds (Scale x y p) = drawPicture (scaleDS x y ds) p+drawPicture ds (Rotate r p) = drawPicture (rotateDS r ds) p+drawPicture ds (Pictures ps) = mapM_ (drawPicture ds) (reverse ps)++drawFrame :: Picture -> Canvas ()+drawFrame pic = do+ Canvas.fillStyle "white"+ Canvas.fillRect (-250, -250, 500, 500)+ drawPicture initialDS pic++setupScreenContext :: (Int, Int) -> Canvas ()+setupScreenContext (cw, ch) = do+ 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++runBlankCanvas :: (Canvas.DeviceContext -> IO ()) -> IO ()+runBlankCanvas act = do+ 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+ where+ options = 3000 { Canvas.events =+ [ "mousedown", "mouseup", "mousemove", "keydown", "keyup"]+ }++display :: Picture -> IO ()+display pic = runBlankCanvas $ \context ->+ Canvas.send context $ Canvas.saveRestore $ do+ let rect = (Canvas.width context, Canvas.height context)+ setupScreenContext rect+ drawFrame pic++pictureOf = drawingOf++drawingOf pic = display pic `catch` reportError+#endif++--------------------------------------------------------------------------------+-- Common activity managing code+++data Activity = Activity {+ activityStep :: Double -> Activity,+ activityEvent :: Event -> Activity,+ activityDraw :: Picture+ }++handleEvent :: Event -> MVar Activity -> IO ()+handleEvent event activity =+ modifyMVar_ activity $ \a0 -> return (activityEvent a0 event)++passTime :: Double -> MVar Activity -> IO Activity+passTime dt activity = modifyMVar activity $ \a0 -> do+ let a1 = activityStep a0 (realToFrac (min dt 0.25))+ return (a1, a1)++--------------------------------------------------------------------------------+-- Common event handling code++keyCodeToText :: Int -> Text+keyCodeToText n = case n of+ _ | n >= 47 && n <= 90 -> fromAscii n+ _ | n >= 96 && n <= 105 -> fromNum (n - 96)+ _ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111)+ 3 -> "Cancel"+ 6 -> "Help"+ 8 -> "Backspace"+ 9 -> "Tab"+ 12 -> "5"+ 13 -> "Enter"+ 16 -> "Shift"+ 17 -> "Ctrl"+ 18 -> "Alt"+ 19 -> "Break"+ 20 -> "CapsLock"+ 27 -> "Esc"+ 32 -> " "+ 33 -> "PageUp"+ 34 -> "PageDown"+ 35 -> "End"+ 36 -> "Home"+ 37 -> "Left"+ 38 -> "Up"+ 39 -> "Right"+ 40 -> "Down"+ 42 -> "*"+ 43 -> "+"+ 44 -> "PrintScreen"+ 45 -> "Insert"+ 46 -> "Delete"+ 106 -> "*"+ 107 -> "+"+ 108 -> "Separator"+ 109 -> "-"+ 110 -> "."+ 111 -> "/"+ 144 -> "NumLock"+ 145 -> "ScrollLock"+ 186 -> ";"+ 187 -> "="+ 188 -> ","+ 189 -> "-"+ 190 -> "."+ 191 -> "/"+ 192 -> "`"+ 219 -> "["+ 220 -> "\\"+ 221 -> "]"+ 222 -> "'"+ _ -> "Unknown:" <> fromNum n+ where fromAscii n = singleton (chr n)+ fromNum n = pack (show (fromIntegral n))+++--------------------------------------------------------------------------------+-- 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+ Just 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++setupEvents :: MVar Activity -> Element -> Element -> IO ()+setupEvents currentActivity canvas offscreen = do+ Just window <- currentWindow+ on window Window.keyDown $ do+ code <- uiKeyCode+ let keyName = keyCodeToText code+ when (keyName /= "") $ do+ liftIO $ handleEvent (KeyPress keyName) currentActivity+ preventDefault+ stopPropagation+ on window Window.keyUp $ do+ code <- uiKeyCode+ let keyName = keyCodeToText code+ when (keyName /= "") $ do+ liftIO $ handleEvent (KeyRelease keyName) currentActivity+ preventDefault+ stopPropagation+ on window Window.mouseDown $ do+ button <- mouseButton+ case fromButtonNum button of+ Nothing -> return ()+ Just btn -> do+ pos <- getMousePos canvas+ liftIO $ handleEvent (MousePress btn pos) currentActivity+ on window Window.mouseUp $ do+ button <- mouseButton+ case fromButtonNum button of+ Nothing -> return ()+ Just btn -> do+ pos <- getMousePos canvas+ liftIO $ handleEvent (MouseRelease btn pos) currentActivity+ on window Window.mouseMove $ do+ pos <- getMousePos canvas+ liftIO $ handleEvent (MouseMovement pos) currentActivity+ return ()++run :: Activity -> IO ()+run startActivity = do+ Just window <- currentWindow+ Just doc <- currentDocument+ Just canvas <- getElementById doc ("screen" :: JSString)+ offscreenCanvas <- Canvas.create 500 500++ setCanvasSize canvas canvas+ setCanvasSize (elementFromCanvas offscreenCanvas) canvas+ on window Window.resize $ do+ liftIO $ setCanvasSize canvas canvas+ liftIO $ setCanvasSize (elementFromCanvas offscreenCanvas) canvas++ currentActivity <- newMVar startActivity+ setupEvents currentActivity canvas (elementFromCanvas offscreenCanvas)++ screen <- js_getCodeWorldContext (canvasFromElement canvas)++ let go t0 a0 = do+ Just rect <- getBoundingClientRect canvas+ buffer <- setupScreenContext (elementFromCanvas offscreenCanvas) rect+ drawFrame buffer (activityDraw a0)+ Canvas.restore buffer++ t1 <- waitForAnimationFrame++ Just rect <- getBoundingClientRect canvas+ cw <- ClientRect.getWidth rect+ ch <- ClientRect.getHeight rect++ Canvas.clearRect 0 0 (realToFrac cw) (realToFrac ch) screen+ js_canvasDrawImage screen (elementFromCanvas offscreenCanvas) 0 0 (round cw) (round ch)+ a1 <- passTime ((t1 - t0) / 1000) currentActivity+ go t1 a1++ t0 <- waitForAnimationFrame+ go t0 startActivity `catch` reportError++--------------------------------------------------------------------------------+-- 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 code)+ | eType == "keyup"+ , Just code <- eWhich+ = Just $ KeyRelease (keyCodeToText 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++run :: Activity -> IO ()+run startActivity = runBlankCanvas $ \context -> do+ let rect = (Canvas.width context, Canvas.height context)++ offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect++ currentActivity <- newMVar startActivity++ let go t0 a0 = do+ Canvas.send context $+ Canvas.with offscreenCanvas $+ Canvas.saveRestore $ do+ setupScreenContext rect+ drawFrame (activityDraw a0)+ tn <- getCurrentTime++ threadDelay $ max 0 (50000 - (round ((tn `diffUTCTime` t0) * 1000000)))+ t1 <- getCurrentTime++ Canvas.send context $ Canvas.drawImageAt (offscreenCanvas, 0, 0)+ a1 <- passTime (realToFrac (t1 `diffUTCTime` t0)) currentActivity++ -- Handle events now+ events <- mapMaybe (toEvent rect) <$> Canvas.flush context+ mapM_ (\e -> handleEvent e currentActivity) events++ go t1 a1++ t0 <- getCurrentTime+ go t0 startActivity `catch` reportError++#endif++--------------------------------------------------------------------------------+-- Common code for interaction, animation and simulation interfaces++interactionOf initial step event draw = go `catch` reportError+ where go = run (activity initial)+ activity x = Activity {+ activityStep = (\dt -> activity (step dt x)),+ activityEvent = (\ev -> activity (event ev x)),+ activityDraw = draw x+ }++data Wrapped a = Wrapped {+ state :: a,+ paused :: Bool,+ mouseMovedTime :: Double+ }++data Control :: * -> * where+ PlayButton :: Control a+ PauseButton :: Control a+ StepButton :: Control a+ RestartButton :: Control Double+ BackButton :: Control Double+ TimeLabel :: Control Double++wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a+wrappedStep f dt w = w {+ state = if paused w then state w else f dt (state w),+ mouseMovedTime = mouseMovedTime w + dt+ }++wrappedEvent :: (Wrapped a -> [Control a])+ -> (Double -> a -> a)+ -> Event -> Wrapped a -> Wrapped a+wrappedEvent _ _ (MouseMovement _) w+ = w { mouseMovedTime = 0 }+wrappedEvent ctrls f (MousePress LeftButton p) w+ = (foldr (handleControl f p) w (ctrls w)) { mouseMovedTime = 0 }+wrappedEvent _ _ _ w = w++handleControl :: (Double -> a -> a)+ -> Point+ -> Control a+ -> Wrapped a+ -> Wrapped a+handleControl _ (x,y) RestartButton w+ | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6+ = w { state = 0 }+handleControl _ (x,y) PlayButton w+ | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6+ = w { paused = False }+handleControl _ (x,y) PauseButton w+ | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6+ = w { paused = True }+handleControl f (x,y) StepButton w+ | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6+ = w { state = f 0.1 (state w) }+handleControl _ (x,y) BackButton w+ | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6+ = w { state = max 0 (state w - 0.1) }+handleControl _ _ _ w = w++wrappedDraw :: (Wrapped a -> [Control a])+ -> (a -> Picture)+ -> Wrapped a -> Picture+wrappedDraw ctrls f w = drawControlPanel ctrls w <> f (state w)++drawControlPanel :: (Wrapped a -> [Control a]) -> Wrapped a -> Picture+drawControlPanel ctrls w = pictures [ drawControl w alpha c | c <- ctrls w ]+ where alpha | mouseMovedTime w < 4.5 = 1+ | mouseMovedTime w < 5.0 = 10 - 2 * mouseMovedTime w+ | otherwise = 0++drawControl :: Wrapped a -> Double -> Control a -> Picture+drawControl _ alpha RestartButton = translated (-9) (-9) p+ where p = colored (RGBA 0 0 0 alpha)+ (thickArc 0.1 (pi / 6) (11 * pi / 6) 0.2 <>+ translated 0.173 (-0.1) (solidRectangle 0.17 0.17))+ <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)+ <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)++drawControl _ alpha PlayButton = translated (-8) (-9) p+ where p = colored (RGBA 0 0 0 alpha)+ (solidPolygon [ (-0.2, 0.25), (-0.2, -0.25), (0.2, 0) ])+ <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)+ <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)++drawControl _ alpha PauseButton = translated (-8) (-9) p+ where p = colored (RGBA 0 0 0 alpha)+ (translated (-0.15) 0 (solidRectangle 0.2 0.6) <>+ translated ( 0.15) 0 (solidRectangle 0.2 0.6))+ <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)+ <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)++drawControl _ alpha StepButton = 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 BackButton = translated (-6) (-9) p+ where p = colored (RGBA 0 0 0 alpha)+ (translated 0.15 0 (solidRectangle 0.2 0.5) <>+ solidPolygon [ (-0.05, 0.25), (-0.05, -0.25), (-0.3, 0) ])+ <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 0.8 0.8)+ <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 0.8 0.8)++drawControl w alpha TimeLabel = translated (8) (-9) p+ where p = colored (RGBA 0 0 0 alpha)+ (scaled 0.5 0.5 $+ text (pack (showFFloatAlt (Just 4) (state w) "s")))+ <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8)+ <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)++animationControls :: Wrapped Double -> [Control Double]+animationControls w+ | mouseMovedTime w > 5 = []+ | paused w && state w > 0 = [ RestartButton, PlayButton, StepButton,+ BackButton, TimeLabel ]+ | paused w = [ RestartButton, PlayButton, StepButton,+ TimeLabel ]+ | otherwise = [ RestartButton, PauseButton, TimeLabel ]++animationOf f =+ interactionOf initial+ (wrappedStep (+))+ (wrappedEvent animationControls (+))+ (wrappedDraw animationControls f)+ where initial = Wrapped {+ state = 0,+ paused = False,+ mouseMovedTime = 1000+ }++simulationControls :: Wrapped w -> [Control w]+simulationControls w+ | mouseMovedTime w > 5 = []+ | paused w = [ PlayButton, StepButton ]+ | otherwise = [ PauseButton ]++simulationOf simInitial simStep simDraw =+ interactionOf initial+ (wrappedStep simStep)+ (wrappedEvent simulationControls simStep)+ (wrappedDraw simulationControls simDraw)+ where initial = Wrapped {+ state = simInitial,+ paused = False,+ mouseMovedTime = 1000+ }+++#ifdef ghcjs_HOST_OS+--------------------------------------------------------------------------------+--- GHCJS implementation of tracing and error handling++foreign import javascript unsafe "window.reportRuntimeError($1, $2);"+ js_reportRuntimeError :: Bool -> JSString -> IO ()++trace msg x = unsafePerformIO $ do+ js_reportRuntimeError False (textToJSString msg)+ return x++reportError :: SomeException -> IO ()+reportError e = js_reportRuntimeError True (textToJSString (pack (show e)))++--------------------------------------------------------------------------------+--- Stand-alone implementation of tracing and error handling+#else++trace = Debug.Trace.trace . T.unpack++reportError :: SomeException -> IO ()+reportError e = hPrint stderr e++#endif
+ src/CodeWorld/Event.hs view
@@ -0,0 +1,64 @@+{-+ Copyright 2016 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++module CodeWorld.Event where++import CodeWorld.Picture (Point)+import Data.Text (Text)++{-| An event initiated by the user.++ Values of this type represent events that the user triggers when+ using an interaction, defined with 'interactionOf'.++ Key events describe the key as 'Text'. Most keys are represented+ by a single character text string, with the capital letter or other+ symbol from the key. Keys that don't correspond to a single+ character use longer names from the following list. Keep in mind+ that not all of these keys appear on all keyboards.++ * Up, Down, Left, and Right for the cursor keys.+ * F1, F2, etc. for function keys.+ * Backspace+ * Tab+ * Enter+ * Shift+ * Ctrl+ * Alt+ * Esc+ * PageUp+ * PageDown+ * End+ * Home+ * Insert+ * Delete+ * CapsLock+ * NumLock+ * ScrollLock+ * PrintScreen+ * Break+ * Separator+ * Cancel+ * Help+-}+data Event = KeyPress !Text+ | KeyRelease !Text+ | MousePress !MouseButton !Point+ | MouseRelease !MouseButton Point+ | MouseMovement !Point+ deriving (Eq, Show)++data MouseButton = LeftButton | MiddleButton | RightButton deriving (Eq, Show)
+ src/CodeWorld/Picture.hs view
@@ -0,0 +1,238 @@+{-+ Copyright 2016 The CodeWorld Authors. All rights reserved.++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++module CodeWorld.Picture where++import CodeWorld.Color+import Data.Monoid ((<>))+import Data.Text (Text, pack)++type Point = (Double, Double)+type Vector = (Double, Double)++vectorSum :: Vector -> Vector -> Vector+vectorSum (x1,y1) (x2,y2) = (x1 + x2, y1 + y2)++vectorDifference :: Vector -> Vector -> Vector+vectorDifference (x1,y1) (x2,y2) = (x1 - x2, y1 - y2)++scaledVector :: Double -> Vector -> Vector+scaledVector k (x,y) = (k*x, k*y)++{-| Angle is in radians -}+rotatedVector :: Double -> Vector -> Vector+rotatedVector angle (x,y) = (x * cos angle - y * sin angle,+ x * sin angle + y * cos angle)++dotProduct :: Vector -> Vector -> Double+dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2++data Picture = Polygon [Point] !Bool+ | Path [Point] !Double !Bool !Bool+ | Sector !Double !Double !Double+ | Arc !Double !Double !Double !Double+ | Text !TextStyle !Font !Text+ | Color !Color !Picture+ | Translate !Double !Double !Picture+ | Scale !Double !Double !Picture+ | Rotate !Double !Picture+ | Pictures [Picture]+ | Logo++data TextStyle = Plain | Bold | Italic++data Font = SansSerif | Serif | Monospace | Handwriting | Fancy | NamedFont !Text++-- | A blank picture+blank :: Picture+blank = Pictures []++-- | A thin sequence of line segments, with these points as endpoints+path :: [Point] -> Picture+path ps = Path ps 0 False False++-- | A thick sequence of line segments, with given line width and endpoints+thickPath :: Double -> [Point] -> Picture+thickPath n ps = Path ps n False False++-- | A thin sequence of line segments, with these points as endpoints+line :: [Point] -> Picture+line ps = Path ps 0 False False+{-# WARNING line "Please use path instead of line" #-}++-- | A thick sequence of line segments, with this line width and endpoints+thickLine :: Double -> [Point] -> Picture+thickLine n ps = Path ps n False False+{-# WARNING thickLine "Please use thickPath instead of thickLine" #-}++-- | A thin polygon with these points as vertices+polygon :: [Point] -> Picture+polygon ps = Path ps 0 True False++-- | A thick polygon with this line width and these points as+-- vertices+thickPolygon :: Double -> [Point] -> Picture+thickPolygon n ps = Path ps n True False++-- | A solid polygon with these points as vertices+solidPolygon :: [Point] -> Picture+solidPolygon ps = Polygon ps False++-- | A smooth curve passing through these points.+curve :: [Point] -> Picture+curve ps = Path ps 0 False True++-- | A thick smooth curve with this line width, passing through these points.+thickCurve :: Double -> [Point] -> Picture+thickCurve n ps = Path ps n False True++-- | A smooth closed loop passing through these points.+loop :: [Point] -> Picture+loop ps = Path ps 0 True True++-- | A thick smooth closed loop with this line width, passing through these points.+thickLoop :: Double -> [Point] -> Picture+thickLoop n ps = Path ps n True True++-- | A solid smooth closed loop passing through these points.+solidLoop :: [Point] -> Picture+solidLoop ps = Polygon ps True++-- | A thin rectangle, with this width and height+rectangle :: Double -> Double -> Picture+rectangle w h = polygon [+ (-w/2, -h/2), (w/2, -h/2), (w/2, h/2), (-w/2, h/2)+ ]++-- | A solid rectangle, with this width and height+solidRectangle :: Double -> Double -> Picture+solidRectangle w h = solidPolygon [+ (-w/2, -h/2), (w/2, -h/2), (w/2, h/2), (-w/2, h/2)+ ]++-- | A thick rectangle, with this line width, and width and height+thickRectangle :: Double -> Double -> Double -> Picture+thickRectangle lw w h = thickPolygon lw [+ (-w/2, -h/2), (w/2, -h/2), (w/2, h/2), (-w/2, h/2)+ ]++-- | A thin circle, with this radius+circle :: Double -> Picture+circle = arc 0 360++-- | A thick circle, with this line width and radius+thickCircle :: Double -> Double -> Picture+thickCircle w = thickArc w 0 360++-- | A thin arc, starting and ending at these angles, with this radius+--+-- Angles are in radians.+arc :: Double -> Double -> Double -> Picture+arc b e r = Arc b e r 0++-- | A thick arc with this line width, starting and ending at these angles,+-- with this radius.+--+-- Angles are in radians.+thickArc :: Double -> Double -> Double -> Double -> Picture+thickArc w b e r = Arc b e r w++-- | A solid circle, with this radius+solidCircle :: Double -> Picture+solidCircle = sector 0 360++-- | A solid sector of a circle (i.e., a pie slice) starting and ending at these+-- angles, with this radius+--+-- Angles are in radians.+sector :: Double -> Double -> Double -> Picture+sector = Sector++-- | A piece of text+text :: Text -> Picture+text = Text Plain Serif++styledText :: TextStyle -> Font -> Text -> Picture+styledText = Text++-- | A picture drawn entirely in this color.+colored :: Color -> Picture -> Picture+colored = Color++-- | A picture drawn entirely in this color.+coloured :: Color -> Picture -> Picture+coloured = Color++-- | A picture drawn translated in these directions.+translated :: Double -> Double -> Picture -> Picture+translated = Translate++-- | A picture scaled by these factors.+scaled :: Double -> Double -> Picture -> Picture+scaled = Scale++-- | A picture scaled by these factors.+dilated :: Double -> Double -> Picture -> Picture+dilated = Scale++-- | A picture rotated by this angle.+--+-- Angles are in radians.+rotated :: Double -> Picture -> Picture+rotated = Rotate++-- A picture made by drawing these pictures, ordered from top to bottom.+pictures :: [Picture] -> Picture+pictures = Pictures++-- Binary composition of pictures.+(&) :: Picture -> Picture -> Picture+infixr 0 &+a & Pictures bs = Pictures (a:bs)+a & b = Pictures [a, b]+{-# WARNING (&) "Please use <> from Data.Monoid instead of &" #-}++instance Monoid Picture where+ mempty = blank+ mappend = (&)+ mconcat = pictures++-- | A coordinate plane. Adding this to your pictures can help you measure distances+-- more accurately.+--+-- Example:+--+-- main = pictureOf(myPicture & coordinatePlane)+-- myPicture = ...+coordinatePlane :: Picture+coordinatePlane = axes & numbers & guidelines+ where xline y = line [(-10, y), (10, y)]+ xaxis = colored (RGBA 0 0 0 0.75) (xline 0)+ axes = xaxis <> rotated (pi/2) xaxis+ xguidelines = pictures+ [colored (RGBA 0 0 0 0.25) (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 ]++-- | The CodeWorld logo.+codeWorldLogo :: Picture+codeWorldLogo = Logo