diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/codeworld-api.cabal b/codeworld-api.cabal new file mode 100644 --- /dev/null +++ b/codeworld-api.cabal @@ -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 +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 . 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 diff --git a/src/CodeWorld.hs b/src/CodeWorld.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld.hs @@ -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 diff --git a/src/CodeWorld/Color.hs b/src/CodeWorld/Color.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Color.hs @@ -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 diff --git a/src/CodeWorld/Driver.hs b/src/CodeWorld/Driver.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Driver.hs @@ -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 diff --git a/src/CodeWorld/Event.hs b/src/CodeWorld/Event.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Event.hs @@ -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) diff --git a/src/CodeWorld/Picture.hs b/src/CodeWorld/Picture.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Picture.hs @@ -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