codeworld-api 0.6.0 → 0.7.0
raw patch · 20 files changed
+754/−1023 lines, 20 filesdep ~ghc-primdep ~ghcjs-domdep ~hashablesetup-changed
Dependency ranges changed: ghc-prim, ghcjs-dom, hashable, reflex, template-haskell, time
Files
- Setup.hs +1/−1
- codeworld-api.cabal +10/−10
- jsbits/sim_fp.js +1/−1
- src/CodeWorld.hs +1/−18
- src/CodeWorld/App.hs +3/−19
- src/CodeWorld/App2.hs +13/−23
- src/CodeWorld/CanvasM.hs +48/−51
- src/CodeWorld/CollaborationUI.hs +1/−1
- src/CodeWorld/Color.hs +14/−71
- src/CodeWorld/DrawState.hs +3/−2
- src/CodeWorld/Driver.hs +504/−475
- src/CodeWorld/EntryPoints.hs +48/−228
- src/CodeWorld/Event.hs +1/−1
- src/CodeWorld/Image.hs +1/−1
- src/CodeWorld/Parameter.hs +1/−1
- src/CodeWorld/Picture.hs +84/−100
- src/CodeWorld/Reflex.hs +17/−17
- src/CodeWorld/Sketches.hs +1/−1
- src/Util/EmbedAsUrl.hs +1/−1
- test/Main.hs +1/−1
Setup.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
codeworld-api.cabal view
@@ -1,11 +1,11 @@ Name: codeworld-api-Version: 0.6.0+Version: 0.7.0 Synopsis: Graphics library for CodeWorld License: Apache License-file: LICENSE Author: The CodeWorld Authors Maintainer: Chris Smith <cdsmith@gmail.com>-Copyright: (c) 2019, The CodeWorld Authors+Copyright: (c) 2020, The CodeWorld Authors Bug-reports: https://github.com/google/codeworld/issues Build-type: Simple Cabal-version: >=1.10@@ -56,13 +56,13 @@ deepseq >= 1.4 && < 1.5, dependent-sum >= 0.4 && < 0.6.2, ghc-prim >= 0.3.1 && < 0.6,- hashable >= 1.2.4 && < 1.3,+ hashable >= 1.2.4 && < 1.4, monad-loops >= 0.3 && < 0.5, mtl >= 2.2.1 && < 2.3, random >= 1.1 && < 1.2, ref-tf >= 0.4 && < 0.5, reflex >= 0.6.3 && < 0.7,- template-haskell >= 2.8 && < 2.15,+ template-haskell >= 2.8 && < 2.16, text >= 1.2.2 && < 1.3, time >= 1.8 && < 2.0, witherable >= 0.3 && < 0.4@@ -73,11 +73,11 @@ ghcjs-prim, codeworld-game-api, codeworld-prediction,- ghcjs-dom >= 0.8 && < 0.9,+ ghcjs-dom >= 0.9 && < 0.9.4, transformers else Build-depends: blank-canvas >= 0.6 && < 0.8,- time >= 1.6.0 && < 1.9+ time >= 1.8 && < 2.0 Ghc-options: -O2 -Wall if flag(strictbuild)@@ -117,13 +117,13 @@ deepseq >= 1.4 && < 1.5, dependent-sum >= 0.4 && < 0.6.2, ghc-prim >= 0.3.1 && < 0.6,- hashable >= 1.2.4 && < 1.3,+ hashable >= 1.2.4 && < 1.4, monad-loops >= 0.3 && < 0.5, mtl >= 2.2.1 && < 2.3, random >= 1.1 && < 1.2, ref-tf >= 0.4 && < 0.5, reflex >= 0.6.3 && < 0.7,- template-haskell >= 2.8 && < 2.15,+ template-haskell >= 2.8 && < 2.16, text >= 1.2.2 && < 1.3, time >= 1.8 && < 2.0, witherable >= 0.3 && < 0.4@@ -134,11 +134,11 @@ ghcjs-prim, codeworld-game-api, codeworld-prediction,- ghcjs-dom >= 0.8 && < 0.9,+ ghcjs-dom >= 0.9 && < 0.9.4, transformers else Build-depends: blank-canvas >= 0.6 && < 0.8,- time >= 1.6.0 && < 1.9+ time >= 1.8 && < 2.0 Ghc-options: -O2 Cpp-options: -DCODEWORLD_UNIT_TEST
jsbits/sim_fp.js view
@@ -1,5 +1,5 @@ /*- * Copyright 2019 The CodeWorld Authors. All rights reserved.+ * Copyright 2020 The CodeWorld Authors. All rights reserved. * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License.
src/CodeWorld.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.@@ -23,12 +23,6 @@ debugActivityOf, groupActivityOf, unsafeGroupActivityOf,- simulationOf,- debugSimulationOf,- interactionOf,- debugInteractionOf,- collaborationOf,- unsafeCollaborationOf, -- * Pictures Picture,@@ -36,9 +30,7 @@ Font (..), blank, polyline,- path, thickPolyline,- thickPath, polygon, thickPolygon, solidPolygon,@@ -56,9 +48,7 @@ arc, sector, thickArc,- text, lettering,- styledText, styledLettering, colored, coloured,@@ -98,15 +88,8 @@ red, green, blue,- cyan,- magenta, yellow,- aquamarine, orange,- azure,- violet,- chartreuse,- rose, brown, pink, purple,
src/CodeWorld/App.hs view
@@ -3,7 +3,7 @@ {-# OPTIONS_GHC -Wno-deprecations -Wno-name-shadowing #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -21,7 +21,6 @@ module CodeWorld.App {-# WARNING "This is an experimental API. It can change at any time." #-} ( Rule,- timeRule, eventRule, pictureRule, multiEventRule,@@ -38,14 +37,10 @@ import System.Random (StdGen) data Rule :: * -> * where- TimeRule :: (Double -> state -> state) -> Rule state EventRule :: (Int -> Event -> state -> state) -> Rule state PictureRule :: (Int -> state -> Picture) -> Rule state Rules :: [Rule state] -> Rule state -timeRule :: (Double -> state -> state) -> Rule state-timeRule = TimeRule- eventRule :: (Event -> state -> state) -> Rule state eventRule = EventRule . const @@ -59,9 +54,6 @@ multiPictureRule = PictureRule subrule :: (a -> b) -> (b -> a -> a) -> Rule b -> Rule a-subrule getter setter (TimeRule step_b) = TimeRule step_a- where- step_a dt a = setter (step_b dt (getter a)) a subrule getter setter (EventRule event_b) = EventRule event_a where event_a k ev a = setter (event_b k ev (getter a)) a@@ -74,14 +66,10 @@ rules = Rules applicationOf :: world -> [Rule world] -> IO ()-applicationOf w rules = interactionOf w step event picture+applicationOf w rules = activityOf w event picture where- step dt = foldl' (.) id [f dt | f <- concatMap stepHandlers rules] event ev = foldl' (.) id [f ev | f <- concatMap eventHandlers rules] picture w = pictures [pic w | pic <- concatMap pictureHandlers rules]- stepHandlers (TimeRule f) = [f]- stepHandlers (Rules rs) = concatMap stepHandlers rs- stepHandlers _ = [] eventHandlers (EventRule f) = [f 0] eventHandlers (Rules rs) = concatMap eventHandlers rs eventHandlers _ = []@@ -91,14 +79,10 @@ unsafeMultiApplicationOf :: Int -> (StdGen -> state) -> [Rule state] -> IO () unsafeMultiApplicationOf n initial rules =- unsafeCollaborationOf n initial step event picture+ unsafeGroupActivityOf n initial event picture where- step dt = foldl' (.) id [f dt | f <- concatMap stepHandlers rules] event k ev = foldl' (.) id [f k ev | f <- concatMap eventHandlers rules] picture k w = pictures [pic k w | pic <- concatMap pictureHandlers rules]- stepHandlers (TimeRule f) = [f]- stepHandlers (Rules rs) = concatMap stepHandlers rs- stepHandlers _ = [] eventHandlers (EventRule f) = [f] eventHandlers (Rules rs) = concatMap eventHandlers rs eventHandlers _ = []
src/CodeWorld/App2.hs view
@@ -3,7 +3,7 @@ {-# OPTIONS_GHC -Wno-deprecations #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -22,7 +22,6 @@ {-# WARNING "This is an experimental API. It can change at any time." #-} ( Application, defaultApplication,- withTimeStep, withEventHandler, withPicture, withMultiEventHandler,@@ -37,46 +36,38 @@ data Application :: * -> * where App :: state ->- (Double -> state -> state) -> (Int -> Event -> state -> state) -> (Int -> state -> Picture) -> Application state defaultApplication :: state -> Application state defaultApplication s =- App s (const id) (const (const id)) (const (const blank))--withTimeStep ::- (Double -> state -> state) ->- Application state ->- Application state-withTimeStep f (App initial step event picture) =- App initial (\dt -> f dt . step dt) event picture+ App s (const (const id)) (const (const blank)) withEventHandler :: (Event -> state -> state) -> Application state -> Application state-withEventHandler f (App initial step event picture) =- App initial step (\k ev -> f ev . event k ev) picture+withEventHandler f (App initial event picture) =+ App initial (\k ev -> f ev . event k ev) picture withPicture :: (state -> Picture) -> Application state -> Application state-withPicture f (App initial step event picture) =- App initial step event (\k s -> f s & picture k s)+withPicture f (App initial event picture) =+ App initial event (\k s -> f s & picture k s) withMultiEventHandler :: (Int -> Event -> state -> state) -> Application state -> Application state-withMultiEventHandler f (App initial step event picture) =- App initial step (\k ev -> f k ev . event k ev) picture+withMultiEventHandler f (App initial event picture) =+ App initial (\k ev -> f k ev . event k ev) picture withMultiPicture :: (Int -> state -> Picture) -> Application state -> Application state-withMultiPicture f (App initial step event picture) =- App initial step event (\k s -> f k s & picture k s)+withMultiPicture f (App initial event picture) =+ App initial event (\k s -> f k s & picture k s) subapplication :: (a -> b) ->@@ -84,13 +75,12 @@ Application b -> (b -> a) -> Application a-subapplication getter setter (App initial step event picture) f =+subapplication getter setter (App initial event picture) f = App (f initial)- (\dt s -> setter (step dt (getter s)) s) (\k ev s -> setter (event k ev (getter s)) s) (\k -> picture k . getter) applicationOf :: Application world -> IO ()-applicationOf (App initial step event picture) =- interactionOf initial step (event 0) (picture 0)+applicationOf (App initial event picture) =+ activityOf initial (event 0) (picture 0)
src/CodeWorld/CanvasM.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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@@ -46,53 +46,53 @@ #endif class (Monad m, MonadIO m) => MonadCanvas m where- type Image m+ type Image m - save :: m ()- restore :: m ()- transform ::- Double -> Double -> Double -> Double -> Double -> Double -> m ()- translate :: Double -> Double -> m ()- scale :: Double -> Double -> m ()- newImage :: Int -> Int -> m (Image m)- builtinImage :: Text -> m (Maybe (Image m))- withImage :: Image m -> m a -> m a- drawImage :: Image m -> Int -> Int -> Int -> Int -> m ()- drawImgURL :: Text -> Text -> Double -> Double -> m ()- globalCompositeOperation :: Text -> m ()- globalAlpha :: Double -> m ()- lineWidth :: Double -> m ()- strokeColor :: Int -> Int -> Int -> Double -> m ()- fillColor :: Int -> Int -> Int -> Double -> m ()- font :: Text -> m ()- textCenter :: m ()- textMiddle :: m ()- beginPath :: m ()- closePath :: m ()- moveTo :: (Double, Double) -> m ()- lineTo :: (Double, Double) -> m ()- quadraticCurveTo :: (Double, Double) -> (Double, Double) -> m ()- bezierCurveTo ::- (Double, Double) -> (Double, Double) -> (Double, Double) -> m ()- arc :: Double -> Double -> Double -> Double -> Double -> Bool -> m ()- rect :: Double -> Double -> Double -> Double -> m ()- clip :: m ()- fill :: m ()- stroke :: m ()- fillRect :: Double -> Double -> Double -> Double -> m ()- fillText :: Text -> (Double, Double) -> m ()- measureText :: Text -> m Double- isPointInPath :: (Double, Double) -> m Bool- isPointInStroke :: (Double, Double) -> m Bool- getScreenWidth :: m Double- getScreenHeight :: m Double+ save :: m ()+ restore :: m ()+ transform ::+ Double -> Double -> Double -> Double -> Double -> Double -> m ()+ translate :: Double -> Double -> m ()+ scale :: Double -> Double -> m ()+ newImage :: Int -> Int -> m (Image m)+ builtinImage :: Text -> m (Maybe (Image m))+ withImage :: Image m -> m a -> m a+ drawImage :: Image m -> Int -> Int -> Int -> Int -> m ()+ drawImgURL :: Text -> Text -> Double -> Double -> m ()+ globalCompositeOperation :: Text -> m ()+ globalAlpha :: Double -> m ()+ lineWidth :: Double -> m ()+ strokeColor :: Int -> Int -> Int -> Double -> m ()+ fillColor :: Int -> Int -> Int -> Double -> m ()+ font :: Text -> m ()+ textCenter :: m ()+ textMiddle :: m ()+ beginPath :: m ()+ closePath :: m ()+ moveTo :: (Double, Double) -> m ()+ lineTo :: (Double, Double) -> m ()+ quadraticCurveTo :: (Double, Double) -> (Double, Double) -> m ()+ bezierCurveTo ::+ (Double, Double) -> (Double, Double) -> (Double, Double) -> m ()+ arc :: Double -> Double -> Double -> Double -> Double -> Bool -> m ()+ rect :: Double -> Double -> Double -> Double -> m ()+ clip :: m ()+ fill :: m ()+ stroke :: m ()+ fillRect :: Double -> Double -> Double -> Double -> m ()+ fillText :: Text -> (Double, Double) -> m ()+ measureText :: Text -> m Double+ isPointInPath :: (Double, Double) -> m Bool+ isPointInStroke :: (Double, Double) -> m Bool+ getScreenWidth :: m Double+ getScreenHeight :: m Double saveRestore :: MonadCanvas m => m a -> m a saveRestore m = do- save- r <- m- restore- return r+ save+ r <- m+ restore+ return r #if defined(ghcjs_HOST_OS) @@ -113,6 +113,9 @@ x <- unCanvasM m dim ctx unCanvasM (f x) dim ctx +foreign import javascript "$6.drawImage($1, $2, $3, $4, $5);"+ js_drawImage :: Element -> Double -> Double -> Double -> Double -> Canvas.Context -> IO ()+ foreign import javascript "$2.globalCompositeOperation = $1;" js_globalCompositeOperation :: JSString -> Canvas.Context -> IO () @@ -167,13 +170,7 @@ CanvasM (const (Canvas.drawImage (Canvas.Image c) x y w h)) drawImgURL name url w h = CanvasM $ \ _ ctx -> do img <- createOrGetImage name url- Canvas.drawImage- (Canvas.Image (unElement img))- (round (-w/2))- (round (-h/2))- (round w)- (round h)- ctx+ js_drawImage img (-w/2) (-h/2) w h ctx globalCompositeOperation op = CanvasM (const (js_globalCompositeOperation (textToJSString op))) globalAlpha a = CanvasM (const (js_globalAlpha a))
src/CodeWorld/CollaborationUI.hs view
@@ -9,7 +9,7 @@ {-# OPTIONS_GHC -Wno-unticked-promoted-constructors -Wno-name-shadowing #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/CodeWorld/Color.hs view
@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -176,97 +176,40 @@ alpha :: Color -> Double alpha (RGBA _ _ _ a) = fence a --- Old-style colors--white, black, red, green, blue, cyan, magenta, yellow :: Color--orange, rose, chartreuse, aquamarine, violet, azure :: Color--gray, grey, brown, purple, pink :: Color+-- Named colors +white :: Color white = HSL 0.00 0.00 1.00 +black :: Color black = HSL 0.00 0.00 0.00 +gray :: Color gray = HSL 0.00 0.00 0.50 +grey :: Color grey = HSL 0.00 0.00 0.50 +red :: Color red = HSL 0.00 0.75 0.50 +orange :: Color orange = HSL 0.61 0.75 0.50 +yellow :: Color yellow = HSL 0.98 0.75 0.50 +green :: Color green = HSL 2.09 0.75 0.50 +blue :: Color blue = HSL 3.84 0.75 0.50 +purple :: Color purple = HSL 4.80 0.75 0.50 +pink :: Color pink = HSL 5.76 0.75 0.75 +brown :: Color brown = HSL 0.52 0.60 0.40--cyan = HSL (3 / 3 * pi) 0.75 0.5--magenta = HSL (5 / 3 * pi) 0.75 0.5--chartreuse = HSL (3 / 6 * pi) 0.75 0.5--aquamarine = HSL (5 / 6 * pi) 0.75 0.5--azure = HSL (7 / 6 * pi) 0.75 0.5--violet = HSL (9 / 6 * pi) 0.75 0.5--rose = HSL (11 / 6 * pi) 0.75 0.5--{-# WARNING- magenta- [ "Please use HSL(5 * pi / 3, 0.75, 0.5) instead of magenta.",- "The variable magenta may be removed July 2020."- ]- #-}--{-# WARNING- cyan- [ "Please use HSL(pi, 0.75, 0.5) instead of cyan.",- "The variable cyan may be removed July 2020."- ]- #-}--{-# WARNING- chartreuse- [ "Please use HSL(pi / 2, 0.75, 0.5) instead of chartreuse.",- "The variable chartreuse may be removed July 2020."- ]- #-}--{-# WARNING- aquamarine- [ "Please use HSL(5 * pi / 6, 0.75, 0.5) instead of aquamarine.",- "The variable aquamarine may be removed July 2020."- ]- #-}--{-# WARNING- azure- [ "Please use HSL(7 * pi / 6, 0.75, 0.5) instead of azure.",- "The variable azure may be removed July 2020."- ]- #-}--{-# WARNING- rose- [ "Please use HSL(11 * pi / 6, 0.75, 0.5) instead of rose.",- "The variable rose may be removed July 2020."- ]- #-}--{-# WARNING- violet- [ "Please use purple instead of violet.",- "The variable violet may be removed July 2020."- ]- #-}
src/CodeWorld/DrawState.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -82,7 +82,8 @@ (b * sin r - d * cos r) e f- where r = 2 * th+ where+ r = 2 * th setColorDS :: Color -> DrawState -> DrawState setColorDS col = mapDSColor $ \mcol ->
src/CodeWorld/Driver.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-name-shadowing -Wno-orphans -Wno-unticked-promoted-constructors #-}- {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}@@ -18,9 +16,10 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-name-shadowing -Wno-orphans -Wno-unticked-promoted-constructors #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -53,7 +52,7 @@ import Data.Dependent.Sum import Data.Foldable import Data.IORef-import Data.List (zip4, intercalate)+import Data.List (intercalate, zip4) import Data.Maybe import Data.Serialize import Data.Serialize.Text ()@@ -86,14 +85,16 @@ import Data.Aeson (ToJSON(..), (.=), object) import Data.Hashable import qualified Data.JSString-import qualified GHCJS.DOM.ClientRect as ClientRect import GHCJS.Concurrent (withoutPreemption) import GHCJS.DOM+import qualified GHCJS.DOM.DOMRect as DOMRect+import GHCJS.DOM.Document (createElement, getBodyUnsafe) import GHCJS.DOM.Element import GHCJS.DOM.EventM import GHCJS.DOM.GlobalEventHandlers hiding (error, keyPress) import GHCJS.DOM.KeyboardEvent import GHCJS.DOM.MouseEvent+import GHCJS.DOM.Node (appendChild) import GHCJS.DOM.NonElementParentNode import GHCJS.DOM.Types (Window, Element, unElement) import GHCJS.Foreign.Callback@@ -101,7 +102,6 @@ import GHCJS.Marshal.Pure import GHCJS.Types import JavaScript.Object-import JavaScript.Web.AnimationFrame import qualified JavaScript.Web.Canvas as Canvas import qualified JavaScript.Web.Canvas.Internal as Canvas import qualified JavaScript.Web.Location as Loc@@ -125,28 +125,28 @@ -- the action that sets up the geometry. withDS :: MonadCanvas m => DrawState -> m a -> m a withDS (DrawState (AffineTransformation ta tb tc td te tf) _col) action =- CM.saveRestore $ do- CM.transform ta tb tc td te tf- CM.beginPath- action+ CM.saveRestore $ do+ CM.transform ta tb tc td te tf+ CM.beginPath+ action setColor :: MonadCanvas m => Color -> m () setColor (RGBA r g b a) = do- CM.strokeColor- (round $ r * 255)- (round $ g * 255)- (round $ b * 255)- a- CM.fillColor- (round $ r * 255)- (round $ g * 255)- (round $ b * 255)- a+ CM.strokeColor+ (round $ r * 255)+ (round $ g * 255)+ (round $ b * 255)+ a+ CM.fillColor+ (round $ r * 255)+ (round $ g * 255)+ (round $ b * 255)+ a applyColor :: MonadCanvas m => DrawState -> m () applyColor ds = case getColorDS ds of- Nothing -> setColor (RGBA 0 0 0 1)- Just c -> setColor c+ Nothing -> setColor (RGBA 0 0 0 1)+ Just c -> setColor c -- | A slower way to draw a picture, which has some useful properties. It -- can draw images in non-standard colors, and apply transparent colors@@ -154,75 +154,75 @@ -- color in the DrawState. viaOffscreen :: MonadCanvas m => Color -> (Color -> m ()) -> m () viaOffscreen (RGBA r g b a) pic = do- w <- CM.getScreenWidth- h <- CM.getScreenHeight- when (w > 0.5 && h > 0.5) $ do- img <- CM.newImage (round w) (round h)- CM.withImage img $ do- setupScreenContext (round w) (round h)- pic (RGBA r g b 1)- CM.saveRestore $ do- px <- pixelSize- CM.scale px (-px)- CM.globalAlpha a- CM.drawImage img (round (-w/2)) (round (-h/2)) (round w) (round h)+ w <- CM.getScreenWidth+ h <- CM.getScreenHeight+ when (w > 0.5 && h > 0.5) $ do+ img <- CM.newImage (round w) (round h)+ CM.withImage img $ do+ setupScreenContext (round w) (round h)+ pic (RGBA r g b 1)+ CM.saveRestore $ do+ px <- pixelSize+ CM.scale px (- px)+ CM.globalAlpha a+ CM.drawImage img (round (- w / 2)) (round (- h / 2)) (round w) (round h) followPath :: MonadCanvas m => [Point] -> Bool -> Bool -> m () followPath [] _ _ = return () followPath [_] _ _ = return ()-followPath ((sx, sy):ps) closed False = do- CM.moveTo (sx, sy)- forM_ ps $ \(x, y) -> CM.lineTo (x, y)- when closed CM.closePath+followPath ((sx, sy) : ps) closed False = do+ CM.moveTo (sx, sy)+ forM_ ps $ \(x, y) -> CM.lineTo (x, y)+ when closed CM.closePath followPath [p1, p2] False True = followPath [p1, p2] False False followPath ps False True = do- let [p1@(x1, y1), p2@(x2, y2), p3@(x3, y3)] = take 3 ps- dprev = euclideanDistance p1 p2- dnext = euclideanDistance p2 p3- p = dprev / (dprev + dnext)- cx = x2 + p * (x1 - x3) / 2- cy = y2 + p * (y1 - y3) / 2- CM.moveTo (x1, y1)- CM.quadraticCurveTo (cx, cy) (x2, y2)- forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \(p1@(x1, y1), p2@(x2, y2), p3@(x3, y3), p4@(x4, y4)) -> do- let dp = euclideanDistance p1 p2- d1 = euclideanDistance p2 p3- d2 = euclideanDistance p3 p4- p = d1 / (d1 + d2)- r = d1 / (dp + d1)- cx1 = x2 + r * (x3 - x1) / 2- cy1 = y2 + r * (y3 - y1) / 2- cx2 = x3 + p * (x2 - x4) / 2- cy2 = y3 + p * (y2 - y4) / 2- CM.bezierCurveTo- (cx1, cy1)- (cx2, cy2)- (x3, y3)- let [p1@(x1, y1), p2@(x2, y2), p3@(x3, y3)] = reverse $ take 3 $ reverse ps- dp = euclideanDistance p1 p2+ let [p1@(x1, y1), p2@(x2, y2), p3@(x3, y3)] = take 3 ps+ dprev = euclideanDistance p1 p2+ dnext = euclideanDistance p2 p3+ p = dprev / (dprev + dnext)+ cx = x2 + p * (x1 - x3) / 2+ cy = y2 + p * (y1 - y3) / 2+ CM.moveTo (x1, y1)+ CM.quadraticCurveTo (cx, cy) (x2, y2)+ forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \(p1@(x1, y1), p2@(x2, y2), p3@(x3, y3), p4@(x4, y4)) -> do+ let dp = euclideanDistance p1 p2 d1 = euclideanDistance p2 p3+ d2 = euclideanDistance p3 p4+ p = d1 / (d1 + d2) r = d1 / (dp + d1)- cx = x2 + r * (x3 - x1) / 2- cy = y2 + r * (y3 - y1) / 2- CM.quadraticCurveTo (cx, cy) (x3, y3)-followPath ps@(_:(sx, sy):_) True True = do- CM.moveTo (sx, sy)- let rep = cycle ps- forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \(p1@(x1, y1), p2@(x2, y2), p3@(x3, y3), p4@(x4, y4)) -> do- let dp = euclideanDistance p1 p2- d1 = euclideanDistance p2 p3- d2 = euclideanDistance p3 p4- p = d1 / (d1 + d2)- r = d1 / (dp + d1)- cx1 = x2 + r * (x3 - x1) / 2- cy1 = y2 + r * (y3 - y1) / 2- cx2 = x3 + p * (x2 - x4) / 2- cy2 = y3 + p * (y2 - y4) / 2- CM.bezierCurveTo- (cx1, cy1)- (cx2, cy2)- (x3, y3)- CM.closePath+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ CM.bezierCurveTo+ (cx1, cy1)+ (cx2, cy2)+ (x3, y3)+ let [p1@(x1, y1), p2@(x2, y2), p3@(x3, y3)] = reverse $ take 3 $ reverse ps+ dp = euclideanDistance p1 p2+ d1 = euclideanDistance p2 p3+ r = d1 / (dp + d1)+ cx = x2 + r * (x3 - x1) / 2+ cy = y2 + r * (y3 - y1) / 2+ CM.quadraticCurveTo (cx, cy) (x3, y3)+followPath ps@(_ : (sx, sy) : _) True True = do+ CM.moveTo (sx, sy)+ let rep = cycle ps+ forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \(p1@(x1, y1), p2@(x2, y2), p3@(x3, y3), p4@(x4, y4)) -> do+ let dp = euclideanDistance p1 p2+ d1 = euclideanDistance p2 p3+ d2 = euclideanDistance p3 p4+ p = d1 / (d1 + d2)+ r = d1 / (dp + d1)+ cx1 = x2 + r * (x3 - x1) / 2+ cy1 = y2 + r * (y3 - y1) / 2+ cx2 = x3 + p * (x2 - x4) / 2+ cy2 = y3 + p * (y2 - y4) / 2+ CM.bezierCurveTo+ (cx1, cy1)+ (cx2, cy2)+ (x3, y3)+ CM.closePath euclideanDistance :: Point -> Point -> Double euclideanDistance (x1, y1) (x2, y2) = sqrt $ square (x2 - x1) + square (y2 - y1)@@ -231,22 +231,22 @@ drawFigure :: MonadCanvas m => DrawState -> Double -> m () -> m () drawFigure ds w figure = do- withDS ds $ do- figure- when (w /= 0) $ do- CM.lineWidth w- applyColor ds- CM.stroke- when (w == 0) $ do- CM.lineWidth =<< pixelSize- applyColor ds- CM.stroke+ withDS ds $ do+ figure+ when (w /= 0) $ do+ CM.lineWidth w+ applyColor ds+ CM.stroke+ when (w == 0) $ do+ CM.lineWidth =<< pixelSize+ applyColor ds+ CM.stroke fillFigure :: MonadCanvas m => DrawState -> m () -> m () fillFigure ds figure = do- withDS ds figure- applyColor ds- CM.fill+ withDS ds figure+ applyColor ds+ CM.fill -------------------------------------------------------------------------------- @@ -284,8 +284,8 @@ drawPicture (Rotate _ r p) ds = drawPicture p (rotateDS r ds) drawPicture (Reflect _ r p) ds = drawPicture p (reflectDS r ds) drawPicture (Clip _ x y p) ds = do- withDS ds $ followPath (rectangleVertices x y) True False- CM.saveRestore $ CM.clip >> drawPicture p ds+ withDS ds $ followPath (rectangleVertices x y) True False+ CM.saveRestore $ CM.clip >> drawPicture p ds drawPicture (Pictures _ ps) ds = forM_ (reverse ps) $ \p -> drawPicture p ds drawPicture (PictureAnd _ ps) ds = forM_ (reverse ps) $ \p -> drawPicture p ds @@ -321,8 +321,8 @@ pictureContains (Rotate _ r p) ds pt = pictureContains p (rotateDS r ds) pt pictureContains (Reflect _ r p) ds pt = pictureContains p (reflectDS r ds) pt pictureContains (Clip _ x y p) ds pt =- (&&) <$> polygonContains (rectangleVertices x y) False ds pt- <*> pictureContains p ds pt+ (&&) <$> polygonContains (rectangleVertices x y) False ds pt+ <*> pictureContains p ds pt pictureContains (Pictures _ ps) ds pt = orM [pictureContains p ds pt | p <- ps] pictureContains (PictureAnd _ ps) ds pt = orM [pictureContains p ds pt | p <- ps] @@ -351,54 +351,54 @@ polygonContains :: MonadCanvas m => [Point] -> Bool -> DrawState -> Point -> m Bool polygonContains ps smooth ds p = do- withDS ds $ followPath ps True smooth- CM.isPointInPath p+ withDS ds $ followPath ps True smooth+ CM.isPointInPath p drawPath :: MonadCanvas m => [Point] -> Double -> Bool -> Bool -> DrawState -> m () drawPath ps w closed smooth ds = drawFigure ds w $ followPath ps closed smooth pathContains :: MonadCanvas m => [Point] -> Double -> Bool -> Bool -> DrawState -> Point -> m Bool pathContains ps w closed smooth ds p = do- s <- pixelSize- drawFigure ds (max s w) $ followPath ps closed smooth- CM.isPointInStroke p+ s <- pixelSize+ drawFigure ds (max s w) $ followPath ps closed smooth+ CM.isPointInStroke p drawSector :: MonadCanvas m => Double -> Double -> Double -> DrawState -> m () drawSector b e r ds =- fillFigure ds $ CM.arc 0 0 (abs r) b e (b > e) >> CM.lineTo (0, 0)+ fillFigure ds $ CM.arc 0 0 (abs r) b e (b > e) >> CM.lineTo (0, 0) sectorContains :: MonadCanvas m => Double -> Double -> Double -> DrawState -> Point -> m Bool sectorContains b e r ds p = do- withDS ds $ CM.arc 0 0 (abs r) b e (b > e) >> CM.lineTo (0, 0)- CM.isPointInPath p+ withDS ds $ CM.arc 0 0 (abs r) b e (b > e) >> CM.lineTo (0, 0)+ CM.isPointInPath p drawArc :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> m () drawArc b e r w ds =- drawFigure ds w $ CM.arc 0 0 (abs r) b e (b > e)+ drawFigure ds w $ CM.arc 0 0 (abs r) b e (b > e) arcContains :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> Point -> m Bool arcContains b e r w ds p = do- s <- pixelSize- let width = max s w- CM.lineWidth width- drawFigure ds width $- CM.arc 0 0 (abs r) b e (b > e)- CM.isPointInStroke p+ s <- pixelSize+ let width = max s w+ CM.lineWidth width+ drawFigure ds width $+ CM.arc 0 0 (abs r) b e (b > e)+ CM.isPointInStroke p drawText :: MonadCanvas m => TextStyle -> Font -> Text -> DrawState -> m () drawText sty fnt txt ds = withDS ds $ do- CM.scale (1/25) (-1/25)- applyColor ds- CM.font (fontString sty fnt)- CM.fillText txt (0, 0)+ CM.scale (1 / 25) (-1 / 25)+ applyColor ds+ CM.font (fontString sty fnt)+ CM.fillText txt (0, 0) textContains :: MonadCanvas m => TextStyle -> Font -> Text -> DrawState -> Point -> m Bool textContains sty fnt txt ds p = do- CM.font (fontString sty fnt)- width <- (/ 25) <$> CM.measureText txt- let height = 1 -- constant, defined in fontString- withDS ds $ CM.rect ((-0.5) * width) ((-0.5) * height) width height- CM.isPointInPath p+ CM.font (fontString sty fnt)+ width <- (/ 25) <$> CM.measureText txt+ let height = 1 -- constant, defined in fontString+ withDS ds $ CM.rect ((-0.5) * width) ((-0.5) * height) width height+ CM.isPointInPath p fontString :: TextStyle -> Font -> Text fontString style font = stylePrefix style <> "25px " <> fontName font@@ -406,7 +406,6 @@ stylePrefix Plain = "" stylePrefix Bold = "bold " stylePrefix Italic = "italic "- fontName SansSerif = "sans-serif" fontName Serif = "serif" fontName Monospace = "monospace"@@ -416,26 +415,26 @@ drawImage :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> m () drawImage name url imgw imgh ds = case getColorDS ds of- -- Fast path: draw in original color.- Nothing -> withDS ds $ do- CM.scale 1 (-1)- CM.drawImgURL name url imgw imgh+ -- Fast path: draw in original color.+ Nothing -> withDS ds $ do+ CM.scale 1 (-1)+ CM.drawImgURL name url imgw imgh - -- Slow path: draw in a different color via an offscreen canvas.- Just oc -> viaOffscreen oc $ \c -> do- setColor c- w <- CM.getScreenWidth- h <- CM.getScreenHeight- CM.fillRect (-w/2) (-h/2) w h- CM.globalCompositeOperation "destination-in"- withDS ds $ do- CM.scale 1 (-1)- CM.drawImgURL name url imgw imgh+ -- Slow path: draw in a different color via an offscreen canvas.+ Just oc -> viaOffscreen oc $ \c -> do+ setColor c+ w <- CM.getScreenWidth+ h <- CM.getScreenHeight+ CM.fillRect (- w / 2) (- h / 2) w h+ CM.globalCompositeOperation "destination-in"+ withDS ds $ do+ CM.scale 1 (-1)+ CM.drawImgURL name url imgw imgh imageContains :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> Point -> m Bool imageContains _ _ imgw imgh ds p = withDS ds $ do- CM.rect (-imgw / 2) (-imgh / 2) imgw imgh- CM.isPointInPath p+ CM.rect (- imgw / 2) (- imgh / 2) imgw imgh+ CM.isPointInPath p coordinatePlanePic :: Picture coordinatePlanePic = axes <> numbers <> guidelines@@ -443,62 +442,62 @@ xline y = colored (RGBA 0 0 0 0.25) $ polyline [(-10, y), (10, y)] xaxis = colored (RGBA 0 0 0 0.75) $ polyline [(-10, 0), (10, 0)] axes = xaxis <> rotated (pi / 2) xaxis- xguidelines = pictures [xline k | k <- [-10,-9 .. 10]]+ xguidelines = pictures [xline k | k <- [-10, -9 .. 10]] guidelines = xguidelines <> rotated (pi / 2) xguidelines numbers = xnumbers <> ynumbers xnumbers =- pictures- [ translated- (fromIntegral k)- 0.3- (scaled 0.5 0.5 (lettering (T.pack (show k))))- | k <- [-9,-8 .. 9]- , k /= (0 :: Int)- ]+ pictures+ [ translated+ (fromIntegral k)+ 0.3+ (scaled 0.5 0.5 (lettering (T.pack (show k))))+ | k <- [-9, -8 .. 9],+ k /= (0 :: Int)+ ] ynumbers =- pictures- [ translated- 0.3- (fromIntegral k)- (scaled 0.5 0.5 (lettering (T.pack (show k))))- | k <- [-9,-8 .. 9]- , k /= (0 :: Int)- ]+ pictures+ [ translated+ 0.3+ (fromIntegral k)+ (scaled 0.5 0.5 (lettering (T.pack (show k))))+ | k <- [-9, -8 .. 9],+ k /= (0 :: Int)+ ] -------------------------------------------------------------------------------- clearScreen :: MonadCanvas m => m () clearScreen = do- w <- CM.getScreenWidth- h <- CM.getScreenHeight- px <- pixelSize- CM.fillColor 255 255 255 1- CM.fillRect (-w/2 * px) (-h/2 * px) (w * px) (h * px)+ w <- CM.getScreenWidth+ h <- CM.getScreenHeight+ px <- pixelSize+ CM.fillColor 255 255 255 1+ CM.fillRect (- w / 2 * px) (- h / 2 * px) (w * px) (h * px) drawFrame :: MonadCanvas m => Picture -> m () drawFrame pic = clearScreen >> drawPicture pic initialDS pixelSize :: MonadCanvas m => m Double pixelSize = do- cw <- CM.getScreenWidth- ch <- CM.getScreenHeight- return $ max (20 / realToFrac cw) (20 / realToFrac ch)+ cw <- CM.getScreenWidth+ ch <- CM.getScreenHeight+ return $ max (20 / realToFrac cw) (20 / realToFrac ch) setupScreenContext :: MonadCanvas m => Int -> Int -> m () setupScreenContext cw ch = do- CM.translate (realToFrac cw / 2) (realToFrac ch / 2)- s <- pixelSize- CM.scale (1/s) (-1/s)- CM.lineWidth 0- CM.textCenter- CM.textMiddle+ CM.translate (realToFrac cw / 2) (realToFrac ch / 2)+ s <- pixelSize+ CM.scale (1 / s) (-1 / s)+ CM.lineWidth 0+ CM.textCenter+ CM.textMiddle -------------------------------------------------------------------------------- -- A NodeId a unique id for each node in a Picture, chosen by the order the node -- appears in DFS. Always >=0.-newtype NodeId = NodeId { getNodeId :: Int}- deriving (Eq, Ord, Enum, Show)+newtype NodeId = NodeId {getNodeId :: Int}+ deriving (Eq, Ord, Enum, Show) getChildNodes :: Picture -> [Picture] getChildNodes (Color _ _ p) = [p]@@ -514,79 +513,82 @@ findTopShape :: MonadCanvas m => DrawState -> Picture -> Double -> Double -> m (Maybe NodeId) findTopShape ds pic x y = do- (found, n) <- searchSingle ds pic x y- return $ if found- then Just (NodeId n)- else Nothing+ (found, n) <- searchSingle ds pic x y+ return $+ if found+ then Just (NodeId n)+ else Nothing where searchSingle ds (Color _ _ p) x y =- fmap (+ 1) <$> searchSingle ds p x y+ fmap (+ 1) <$> searchSingle ds p x y searchSingle ds (Translate _ dx dy p) x y =- fmap (+ 1) <$> searchSingle (translateDS dx dy ds) p x y+ fmap (+ 1) <$> searchSingle (translateDS dx dy ds) p x y searchSingle ds (Scale _ sx sy p) x y =- fmap (+ 1) <$> searchSingle (scaleDS sx sy ds) p x y+ fmap (+ 1) <$> searchSingle (scaleDS sx sy ds) p x y searchSingle ds (Dilate _ k p) x y =- fmap (+ 1) <$> searchSingle (scaleDS k k ds) p x y+ fmap (+ 1) <$> searchSingle (scaleDS k k ds) p x y searchSingle ds (Rotate _ a p) x y =- fmap (+ 1) <$> searchSingle (rotateDS a ds) p x y+ fmap (+ 1) <$> searchSingle (rotateDS a ds) p x y searchSingle ds (Reflect _ a p) x y =- fmap (+ 1) <$> searchSingle (reflectDS a ds) p x y+ fmap (+ 1) <$> searchSingle (reflectDS a ds) p x y searchSingle ds (Clip _ w h p) x y = do- inClip <- polygonContains (rectangleVertices w h) False ds (x, y)- fmap (+ 1) <$> if inClip- then searchSingle ds p x y- else return (False, countNodes p)+ inClip <- polygonContains (rectangleVertices w h) False ds (x, y)+ fmap (+ 1)+ <$> if inClip+ then searchSingle ds p x y+ else return (False, countNodes p) searchSingle ds (Pictures _ ps) x y =- fmap (+ 1) <$> searchMulti ds ps x y+ fmap (+ 1) <$> searchMulti ds ps x y searchSingle ds (PictureAnd _ ps) x y =- fmap (+ 1) <$> searchMulti ds ps x y+ fmap (+ 1) <$> searchMulti ds ps x y searchSingle ds p x y = do- contained <- pictureContains p ds (x, y)- if contained- then pure (True, 0)- else pure (False, 1)-+ contained <- pictureContains p ds (x, y)+ if contained+ then pure (True, 0)+ else pure (False, 1) searchMulti _ [] _ _ = return (False, 0)- searchMulti ds (pic:pics) x y = do- (found, count) <- searchSingle ds pic x y- if found- then pure (True, count)- else fmap (+ count) <$> searchMulti ds pics x y-+ searchMulti ds (pic : pics) x y = do+ (found, count) <- searchSingle ds pic x y+ if found+ then pure (True, count)+ else fmap (+ count) <$> searchMulti ds pics x y countNodes p = 1 + sum (map countNodes (getChildNodes p)) -- If a picture is found, the result will include an array of the base picture -- and all transformations. findTopShapeFromPoint :: MonadCanvas m => Point -> Picture -> m (Maybe NodeId) findTopShapeFromPoint (x, y) pic = do- cw <- CM.getScreenWidth- ch <- CM.getScreenHeight- img <- CM.newImage (round cw) (round ch)- CM.withImage img $ do- setupScreenContext (round cw) (round ch)- findTopShape initialDS pic x y+ cw <- CM.getScreenWidth+ ch <- CM.getScreenHeight+ img <- CM.newImage (round cw) (round ch)+ CM.withImage img $ do+ setupScreenContext (round cw) (round ch)+ findTopShape initialDS pic x y trim :: Int -> String -> String trim x y | x >= length y = y | otherwise = take mid y ++ "..." ++ reverse (take mid $ reverse y)- where mid = (x - 3) `div` 2+ where+ mid = (x - 3) `div` 2 showFloat :: Bool -> Double -> String showFloat needNegParens x | needNegParens && x < 0 = "(" ++ result ++ ")" | otherwise = result- where result = stripZeros (showFFloatAlt (Just 4) x "")- stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse+ where+ result = stripZeros (showFFloatAlt (Just 4) x "")+ stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse showPoints :: [Point] -> String showPoints pts =- "[" ++- intercalate ", " [- "(" ++ showFloat False x ++ ", " ++ showFloat False y ++ ")"+ "["+ ++ intercalate+ ", "+ [ "(" ++ showFloat False x ++ ", " ++ showFloat False y ++ ")" | (x, y) <- pts- ] ++- "]"+ ]+ ++ "]" showColor :: Color -> String showColor c@(RGBA r g b a)@@ -601,109 +603,110 @@ | c == pink = "pink" | c == purple = "purple" | c == gray = "gray"- | haskellMode, a == 1 =- printf "(RGB %s %s %s)" (showFloat True r) (showFloat True g) (showFloat True b)+ | haskellMode,+ a == 1 =+ printf "(RGB %s %s %s)" (showFloat True r) (showFloat True g) (showFloat True b) | a == 1 =- printf "RGB(%s, %s, %s)" (showFloat False r) (showFloat False g) (showFloat False b)+ printf "RGB(%s, %s, %s)" (showFloat False r) (showFloat False g) (showFloat False b) | haskellMode =- printf "(RGBA %s %s %s %s)" (showFloat True r) (showFloat True g) (showFloat True b) (showFloat True a)+ printf "(RGBA %s %s %s %s)" (showFloat True r) (showFloat True g) (showFloat True b) (showFloat True a) | otherwise =- printf "RGBA(%s, %s, %s, %s)" (showFloat False r) (showFloat False g) (showFloat False b) (showFloat False a)+ printf "RGBA(%s, %s, %s, %s)" (showFloat False r) (showFloat False g) (showFloat False b) (showFloat False a) describePicture :: Picture -> String describePicture (Rectangle _ w h) | haskellMode = printf "rectangle %s %s" (showFloat True w) (showFloat True h)- | otherwise = printf "rectangle(%s, %s)" (showFloat False w) (showFloat False h)+ | otherwise = printf "rectangle(%s, %s)" (showFloat False w) (showFloat False h) describePicture (SolidRectangle _ w h) | haskellMode = printf "solidRectangle %s %s" (showFloat True w) (showFloat True h)- | otherwise = printf "solidRectangle(%s, %s)" (showFloat False w) (showFloat False h)+ | otherwise = printf "solidRectangle(%s, %s)" (showFloat False w) (showFloat False h) describePicture (ThickRectangle _ lw w h) | haskellMode = printf "thickRectangle %s %s %s" (showFloat True lw) (showFloat True w) (showFloat True h)- | otherwise = printf "thickRectangle(%s, %s, %s)" (showFloat False w) (showFloat False h) (showFloat False lw)+ | otherwise = printf "thickRectangle(%s, %s, %s)" (showFloat False w) (showFloat False h) (showFloat False lw) describePicture (Circle _ r) | haskellMode = printf "circle %s" (showFloat True r)- | otherwise = printf "circle(%s)" (showFloat False r)+ | otherwise = printf "circle(%s)" (showFloat False r) describePicture (SolidCircle _ r) | haskellMode = printf "solidCircle %s" (showFloat True r)- | otherwise = printf "solidCircle(%s)" (showFloat False r)+ | otherwise = printf "solidCircle(%s)" (showFloat False r) describePicture (ThickCircle _ lw r) | haskellMode = printf "thickCircle %s %s" (showFloat True lw) (showFloat True r)- | otherwise = printf "thickCircle(%s, %s)" (showFloat False r) (showFloat False lw)+ | otherwise = printf "thickCircle(%s, %s)" (showFloat False r) (showFloat False lw) describePicture (SolidPolygon _ pts) | haskellMode = printf "solidPolygon %s" (showPoints pts)- | otherwise = printf "solidPolygon(%s)" (showPoints pts)+ | otherwise = printf "solidPolygon(%s)" (showPoints pts) describePicture (SolidClosedCurve _ pts) | haskellMode = printf "solidClosedCurve %s" (showPoints pts)- | otherwise = printf "solidClosedCurve(%s)" (showPoints pts)+ | otherwise = printf "solidClosedCurve(%s)" (showPoints pts) describePicture (Polygon _ pts) | haskellMode = printf "polygon %s" (showPoints pts)- | otherwise = printf "polygon(%s)" (showPoints pts)+ | otherwise = printf "polygon(%s)" (showPoints pts) describePicture (ThickPolygon _ pts w) | haskellMode = printf "thickPolygon %s %s" (showFloat True w) (showPoints pts)- | otherwise = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat False w)+ | otherwise = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat False w) describePicture (ClosedCurve _ pts) | haskellMode = printf "closedCurve %s" (showPoints pts)- | otherwise = printf "closedCurve(%s)" (showPoints pts)+ | otherwise = printf "closedCurve(%s)" (showPoints pts) describePicture (ThickClosedCurve _ pts w) | haskellMode = printf "thickClosedCurve %s %s" (showFloat True w) (showPoints pts)- | otherwise = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat False w)+ | otherwise = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat False w) describePicture (Polyline _ pts) | haskellMode = printf "polyline %s" (showPoints pts)- | otherwise = printf "polyline(%s)" (showPoints pts)+ | otherwise = printf "polyline(%s)" (showPoints pts) describePicture (ThickPolyline _ pts w) | haskellMode = printf "thickPolyline %s %s" (showFloat True w) (showPoints pts)- | otherwise = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat False w)+ | otherwise = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat False w) describePicture (Curve _ pts) | haskellMode = printf "curve %s" (showPoints pts)- | otherwise = printf "curve(%s)" (showPoints pts)+ | otherwise = printf "curve(%s)" (showPoints pts) describePicture (ThickCurve _ pts w) | haskellMode = printf "thickCurve %s %s" (showFloat True w) (showPoints pts)- | otherwise = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat False w)+ | otherwise = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat False w) describePicture (Sector _ b e r) | haskellMode = printf "sector %s %s %s" (showFloat True b) (showFloat True e) (showFloat True r)- | otherwise = printf "sector(%s°, %s°, %s)" (showFloat False (180 * b / pi)) (showFloat False (180 * e / pi)) (showFloat False r)+ | otherwise = printf "sector(%s°, %s°, %s)" (showFloat False (180 * b / pi)) (showFloat False (180 * e / pi)) (showFloat False r) describePicture (Arc _ b e r) | haskellMode = printf "arc %s %s %s" (showFloat True b) (showFloat True e) (showFloat True r)- | otherwise = printf "arc(%s°, %s°, %s)" (showFloat False (180 * b / pi)) (showFloat False (180 * e / pi)) (showFloat False r)+ | otherwise = printf "arc(%s°, %s°, %s)" (showFloat False (180 * b / pi)) (showFloat False (180 * e / pi)) (showFloat False r) describePicture (ThickArc _ b e r w) | haskellMode = printf "thickArc %s %s %s %s" (showFloat True w) (showFloat True b) (showFloat True e) (showFloat True r)- | otherwise = printf "thickArc(%s°, %s°, %s, %s)" (showFloat False (180 * b / pi)) (showFloat False (180 * e / pi)) (showFloat False r) (showFloat False w)+ | otherwise = printf "thickArc(%s°, %s°, %s, %s)" (showFloat False (180 * b / pi)) (showFloat False (180 * e / pi)) (showFloat False r) (showFloat False w) describePicture (Lettering _ txt) | haskellMode = printf "lettering %s" (show txt)- | otherwise = printf "lettering(%s)" (show txt)+ | otherwise = printf "lettering(%s)" (show txt) describePicture (Blank _) = "blank" describePicture (StyledLettering _ style font txt) | haskellMode = printf "styledLettering %s %s %s" (showsPrec 10 style "") (showsPrec 10 font "") (show txt)- | otherwise = printf "styledLettering(%s, %s, %s)" (show txt) (show font) (show style)+ | otherwise = printf "styledLettering(%s, %s, %s)" (show txt) (show font) (show style) describePicture (Color _ c _) | haskellMode = printf "colored %s" (showColor c)- | otherwise = printf "colored(..., %s)" (showColor c)+ | otherwise = printf "colored(..., %s)" (showColor c) describePicture (Translate _ x y _) | haskellMode = printf "translated %s %s" (showFloat True x) (showFloat True y)- | otherwise = printf "translated(..., %s, %s)" (showFloat False x) (showFloat False y)+ | otherwise = printf "translated(..., %s, %s)" (showFloat False x) (showFloat False y) describePicture (Scale _ x y _) | haskellMode = printf "scaled %s %s" (showFloat True x) (showFloat True y)- | otherwise = printf "scaled(..., %s, %s)" (showFloat False x) (showFloat False y)+ | otherwise = printf "scaled(..., %s, %s)" (showFloat False x) (showFloat False y) describePicture (Rotate _ angle _) | haskellMode = printf "rotated %s" (showFloat True angle)- | otherwise = printf "rotated(..., %s°)" (showFloat False (180 * angle / pi))+ | otherwise = printf "rotated(..., %s°)" (showFloat False (180 * angle / pi)) describePicture (Reflect _ angle _) | haskellMode = printf "reflected %s" (showFloat True angle)- | otherwise = printf "reflected(..., %s°)" (showFloat False (180 * angle / pi))+ | otherwise = printf "reflected(..., %s°)" (showFloat False (180 * angle / pi)) describePicture (Clip _ x y _) | haskellMode = printf "clipped %s %s" (showFloat True x) (showFloat True y)- | otherwise = printf "rotated(..., %s, %s)" (showFloat False x) (showFloat False y)+ | otherwise = printf "clipped(..., %s, %s)" (showFloat False x) (showFloat False y) describePicture (Dilate _ k _) | haskellMode = printf "dilated %s" (showFloat True k)- | otherwise = printf "dilated(..., %s)" (showFloat False k)+ | otherwise = printf "dilated(..., %s)" (showFloat False k) describePicture (Sketch _ name _ _ _) = T.unpack name describePicture (CoordinatePlane _) = "coordinatePlane" describePicture (Pictures _ _) | haskellMode = "pictures"- | otherwise = "pictures(...)"+ | otherwise = "pictures(...)" describePicture (PictureAnd _ _) | haskellMode = "(&)"- | otherwise = "... & ..."+ | otherwise = "... & ..." getPictureSrcLoc :: Picture -> Maybe SrcLoc getPictureSrcLoc (SolidPolygon loc _) = loc@@ -752,8 +755,26 @@ foreign import javascript unsafe "$1.getContext('2d', { alpha: false })" getCodeWorldContext :: Canvas.Canvas -> IO Canvas.Context +getCanvas :: IO Element+getCanvas = do+ js_showCanvas+ Just doc <- currentDocument+ mcanvas <- getElementById doc ("screen" :: JSString)+ case mcanvas of+ Just canvas -> return canvas+ Nothing -> do+ body <- getBodyUnsafe doc+ setAttribute body ("style" :: JSString)+ ("margin: 0; overflow: hidden" :: JSString)+ canvas <- createElement doc ("canvas" :: JSString)+ setAttribute canvas ("id" :: JSString) ("screen" :: JSString)+ setAttribute canvas ("style" :: JSString)+ ("cursor: default; width: 100vw; height: 100vh;" :: JSString)+ _ <- appendChild body canvas+ return canvas+ foreign import javascript unsafe "showCanvas()"- showCanvas :: IO ()+ js_showCanvas :: IO () canvasFromElement :: Element -> Canvas.Canvas canvasFromElement = Canvas.Canvas . unElement@@ -769,8 +790,8 @@ setCanvasSize (elementFromCanvas offscreenCanvas) canvas rect <- getBoundingClientRect canvas withScreen (elementFromCanvas offscreenCanvas) rect (drawFrame pic)- cw <- ClientRect.getWidth rect- ch <- ClientRect.getHeight rect+ cw <- DOMRect.getWidth rect+ ch <- DOMRect.getHeight rect when (cw > 0.5 && ch > 0.5) $ canvasDrawImage screen (elementFromCanvas offscreenCanvas) 0 0 (round cw) (round ch)@@ -859,15 +880,15 @@ let nodeName = trim 80 . describePicture $ pic let nodeSrcLoc = getPictureSrcLoc pic nodeSubs <- getSubNodes- pure Node{..}+ pure (Node {..}) foreign import javascript unsafe "/\\bmode=haskell\\b/.test(location.search)" haskellMode :: Bool -withScreen :: Element -> ClientRect.ClientRect -> CanvasM a -> IO a+withScreen :: Element -> DOMRect.DOMRect -> CanvasM a -> IO a withScreen canvas rect action = do- cw <- realToFrac <$> ClientRect.getWidth rect- ch <- realToFrac <$> ClientRect.getHeight rect+ cw <- realToFrac <$> DOMRect.getWidth rect+ ch <- realToFrac <$> DOMRect.getHeight rect ctx <- getCodeWorldContext (canvasFromElement canvas) runCanvasM (cw, ch) ctx $ CM.saveRestore $ do setupScreenContext (round cw) (round ch)@@ -876,8 +897,8 @@ setCanvasSize :: Element -> Element -> IO () setCanvasSize target canvas = do rect <- getBoundingClientRect canvas- cx <- ClientRect.getWidth rect- cy <- ClientRect.getHeight rect+ cx <- DOMRect.getWidth rect+ cy <- DOMRect.getHeight rect setAttribute target ("width" :: JSString) (show (round cx :: Int)) setAttribute target ("height" :: JSString) (show (round cy :: Int)) @@ -916,106 +937,111 @@ keyCodeToText :: Word -> Text keyCodeToText n =- case n of- _ | n >= 47 && n <= 90 -> fromAscii n- _ | n >= 96 && n <= 105 -> fromNum (n - 96)- _ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111)- 3 -> "Cancel"- 6 -> "Help"- 8 -> "Backspace"- 9 -> "Tab"- 12 -> "5"- 13 -> "Enter"- 16 -> "Shift"- 17 -> "Ctrl"- 18 -> "Alt"- 19 -> "Break"- 20 -> "CapsLock"- 27 -> "Esc"- 32 -> " "- 33 -> "PageUp"- 34 -> "PageDown"- 35 -> "End"- 36 -> "Home"- 37 -> "Left"- 38 -> "Up"- 39 -> "Right"- 40 -> "Down"- 42 -> "*"- 43 -> "+"- 44 -> "PrintScreen"- 45 -> "Insert"- 46 -> "Delete"- 47 -> "Help"- 91 -> "OS"- 92 -> "OS"- 93 -> "ContextMenu"- 106 -> "*"- 107 -> "+"- 108 -> ","- 109 -> "-"- 110 -> "."- 111 -> "/"- 144 -> "NumLock"- 145 -> "ScrollLock"- 173 -> "-"- 186 -> ";"- 187 -> "="- 188 -> ","- 189 -> "-"- 190 -> "."- 191 -> "/"- 192 -> "`"- 193 -> "IntlRo"- 194 -> ","- 219 -> "["- 220 -> "\\"- 221 -> "]"- 222 -> "'"- 225 -> "AltGraph"- 255 -> "IntlYen"- _ -> "Unknown:" <> fromNum n+ case n of+ _ | n >= 47 && n <= 90 -> fromAscii n+ _ | n >= 96 && n <= 105 -> fromNum (n - 96)+ _ | n >= 112 && n <= 135 -> "F" <> fromNum (n - 111)+ 3 -> "Cancel"+ 6 -> "Help"+ 8 -> "Backspace"+ 9 -> "Tab"+ 12 -> "5"+ 13 -> "Enter"+ 16 -> "Shift"+ 17 -> "Ctrl"+ 18 -> "Alt"+ 19 -> "Break"+ 20 -> "CapsLock"+ 27 -> "Esc"+ 32 -> " "+ 33 -> "PageUp"+ 34 -> "PageDown"+ 35 -> "End"+ 36 -> "Home"+ 37 -> "Left"+ 38 -> "Up"+ 39 -> "Right"+ 40 -> "Down"+ 42 -> "*"+ 43 -> "+"+ 44 -> "PrintScreen"+ 45 -> "Insert"+ 46 -> "Delete"+ 47 -> "Help"+ 91 -> "OS"+ 92 -> "OS"+ 93 -> "ContextMenu"+ 106 -> "*"+ 107 -> "+"+ 108 -> ","+ 109 -> "-"+ 110 -> "."+ 111 -> "/"+ 144 -> "NumLock"+ 145 -> "ScrollLock"+ 173 -> "-"+ 186 -> ";"+ 187 -> "="+ 188 -> ","+ 189 -> "-"+ 190 -> "."+ 191 -> "/"+ 192 -> "`"+ 193 -> "IntlRo"+ 194 -> ","+ 219 -> "["+ 220 -> "\\"+ 221 -> "]"+ 222 -> "'"+ 225 -> "AltGraph"+ 255 -> "IntlYen"+ _ -> "Unknown:" <> fromNum n where fromAscii n = T.singleton (chr (fromIntegral n)) fromNum n = T.pack (show n) isUniversallyConstant :: (a -> s -> s) -> s -> Bool isUniversallyConstant f old =- unsafePerformIO $ falseOr $ do- oldName <- makeStableName $! old- genName <- makeStableName $! f undefined old- return (genName == oldName)+ unsafePerformIO $ falseOr $ do+ oldName <- makeStableName $! old+ genName <- makeStableName $! f undefined old+ return (genName == oldName) where falseOr x = x `catch` \(_ :: SomeException) -> return False ifDifferent :: (s -> s) -> s -> Maybe s ifDifferent f s0 = unsafePerformIO $ do- oldName <- makeStableName $! s0- newName <- makeStableName $! s1- if newName == oldName then return Nothing else return (Just s1)- where s1 = f s0+ oldName <- makeStableName $! s0+ newName <- makeStableName $! s1+ if newName == oldName then return Nothing else return (Just s1)+ where+ s1 = f s0 modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool modifyMVarIfDifferent var f =- modifyMVar var $ \s0 ->- case ifDifferent f s0 of- Nothing -> return (s0, False)- Just s1 -> return (s1, True)+ modifyMVar var $ \s0 ->+ case ifDifferent f s0 of+ Nothing -> return (s0, False)+ Just s1 -> return (s1, True) data GameToken- = FullToken { tokenDeployHash :: Text- , tokenNumPlayers :: Int- , tokenInitial :: StaticKey- , tokenStep :: StaticKey- , tokenEvent :: StaticKey- , tokenDraw :: StaticKey }- | SteplessToken { tokenDeployHash :: Text- , tokenNumPlayers :: Int- , tokenInitial :: StaticKey- , tokenEvent :: StaticKey- , tokenDraw :: StaticKey }- | PartialToken { tokenDeployHash :: Text }- deriving (Generic)+ = FullToken+ { tokenDeployHash :: Text,+ tokenNumPlayers :: Int,+ tokenInitial :: StaticKey,+ tokenStep :: StaticKey,+ tokenEvent :: StaticKey,+ tokenDraw :: StaticKey+ }+ | SteplessToken+ { tokenDeployHash :: Text,+ tokenNumPlayers :: Int,+ tokenInitial :: StaticKey,+ tokenEvent :: StaticKey,+ tokenDraw :: StaticKey+ }+ | PartialToken {tokenDeployHash :: Text}+ deriving (Generic) deriving instance Generic Fingerprint @@ -1031,10 +1057,10 @@ screenCoordsToPoint :: Element -> Double -> Double -> IO Point screenCoordsToPoint canvas sx sy = do rect <- getBoundingClientRect canvas- cx <- realToFrac <$> ClientRect.getLeft rect- cy <- realToFrac <$> ClientRect.getTop rect- cw <- realToFrac <$> ClientRect.getWidth rect- ch <- realToFrac <$> ClientRect.getHeight rect+ cx <- realToFrac <$> DOMRect.getX rect+ cy <- realToFrac <$> DOMRect.getY rect+ cw <- realToFrac <$> DOMRect.getWidth rect+ ch <- realToFrac <$> DOMRect.getHeight rect let unitLen = min cw ch / 20 let midx = cx + cw / 2 let midy = cy + ch / 2@@ -1292,16 +1318,13 @@ enableDeterministicMath let fullStepHandler dt = stepHandler dt . eventHandler (-1) (TimePassing dt) - Just window <- currentWindow- Just doc <- currentDocument- Just canvas <- getElementById doc ("screen" :: JSString)-+ canvas <- getCanvas setCanvasSize canvas canvas++ Just window <- currentWindow _ <- on window resize $ do liftIO $ setCanvasSize canvas canvas - showCanvas- frameRenderer <- createFrameRenderer canvas currentGameState <- newMVar initialGameState@@ -1344,18 +1367,15 @@ run initial stepHandler eventHandler drawHandler injectTime = do let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt) - Just window <- currentWindow- Just doc <- currentDocument- Just canvas <- getElementById doc ("screen" :: JSString)+ canvas <- getCanvas needsRedraw <- newMVar ()+ Just window <- currentWindow _ <- on window resize $ void $ liftIO $ do setCanvasSize canvas canvas tryPutMVar needsRedraw () setCanvasSize canvas canvas - showCanvas- frameRenderer <- createFrameRenderer canvas currentState <- newMVar initial eventHappened <- newMVar ()@@ -1400,10 +1420,10 @@ getNodeAtCoords :: Element -> Double -> Double -> Picture -> IO (Maybe NodeId) getNodeAtCoords canvas x y pic = do rect <- getBoundingClientRect canvas- cx <- realToFrac <$> ClientRect.getLeft rect- cy <- realToFrac <$> ClientRect.getTop rect- cw <- realToFrac <$> ClientRect.getWidth rect- ch <- realToFrac <$> ClientRect.getHeight rect+ cx <- realToFrac <$> DOMRect.getX rect+ cy <- realToFrac <$> DOMRect.getY rect+ cw <- realToFrac <$> DOMRect.getWidth rect+ ch <- realToFrac <$> DOMRect.getHeight rect -- It's safe to pass undefined for the context because -- findTopShapeFromPoint only draws to an offscreen buffer.@@ -1518,12 +1538,6 @@ -- Sample the current user picture to return the scene tree. getPicCB <- syncCallback' $ samplePicture >>= toJSVal_aeson . pictureToNode - -- Sample the current user picture to draw to a canvas.- drawCB <- syncCallback2 ContinueAsync $ \c n -> do- let canvas = unsafeCoerce c :: Element- let nodeId = NodeId (pFromJSVal n)- drawPartialPic canvas nodeId =<< samplePicture- -- Fire an event to change debug active state. setActiveCB <- syncCallback1 ContinueAsync $ \ active -> case pFromJSVal active of True -> fireUpdate startDebugState@@ -1537,14 +1551,13 @@ if isHighlight then fireUpdate (highlightDebugState nodeId) else fireUpdate (selectDebugState nodeId) - js_initDebugMode getNodeCB setActiveCB getPicCB highlightCB drawCB+ js_initDebugMode getNodeCB setActiveCB getPicCB highlightCB -foreign import javascript unsafe "initDebugMode($1,$2,$3,$4,$5)"+foreign import javascript unsafe "initDebugMode($1,$2,$3,$4)" js_initDebugMode :: Callback (JSVal -> IO JSVal) -> Callback (JSVal -> IO ()) -> Callback (IO JSVal) -> Callback (JSVal -> JSVal -> IO ())- -> Callback (JSVal -> JSVal -> IO ()) -> IO () -- Utility functions that apply a function in either the left or right half of a@@ -1584,8 +1597,6 @@ -- there are deferred type errors that are effectively compile errors. evaluate $ rnf $ rawDraw initial - Just doc <- currentDocument- Just canvas <- getElementById doc ("screen" :: JSString) let debugInitial = (debugStateInit, initial) debugStep dt s@(debugState, _) = case debugStateActive debugState of@@ -1601,8 +1612,11 @@ debugRawDraw (_debugState, s) = rawDraw s (sendEvent, getState) <- run debugInitial debugStep debugEvent debugDraw (Right . TimePassing)++ canvas <- getCanvas onEvents canvas (sendEvent . Right) connectInspect canvas (debugRawDraw <$> getState) (sendEvent . Left)+ waitForever #else@@ -1621,7 +1635,7 @@ my = h' / 2 toEvent :: (Int, Int) -> Canvas.Event -> Maybe Event-toEvent rect Canvas.Event {..}+toEvent rect (Canvas.Event {..}) | eType == "keydown" , Just code <- eWhich = Just $ KeyPress (keyCodeToText (fromIntegral code)) | eType == "keyup"@@ -1715,8 +1729,8 @@ -------------------------------------------------------------------------------- -- FRP implementation -data ReactiveInput t = ReactiveInput {- keyPress :: R.Event t Text,+data ReactiveInput t = ReactiveInput+ { keyPress :: R.Event t Text, keyRelease :: R.Event t Text, textEntry :: R.Event t Text, pointerPress :: R.Event t Point,@@ -1724,86 +1738,98 @@ pointerPosition :: R.Dynamic t Point, pointerDown :: R.Dynamic t Bool, timePassing :: R.Event t Double- }+ } -data ReactiveOutput = ReactiveOutput {- userPictures :: [Picture],+data ReactiveOutput = ReactiveOutput+ { userPictures :: [Picture], userTransform :: Picture -> Picture, systemPicture :: Picture- }+ } instance Semigroup ReactiveOutput where- a <> b = ReactiveOutput {- userPictures = userPictures a ++ userPictures b,+ a <> b =+ ReactiveOutput+ { userPictures = userPictures a ++ userPictures b, userTransform = userTransform a . userTransform b, systemPicture = systemPicture a & systemPicture b- }+ } instance Monoid ReactiveOutput where- mempty = ReactiveOutput [] id blank+ mempty = ReactiveOutput [] id blank -newtype ReactiveProgram t m a = ReactiveProgram {- unReactiveProgram :: ReaderT (ReactiveInput t) (R.DynamicWriterT t ReactiveOutput m) a- }+newtype ReactiveProgram t m a = ReactiveProgram+ { unReactiveProgram :: ReaderT (ReactiveInput t) (R.DynamicWriterT t ReactiveOutput m) a+ } deriving instance Functor m => Functor (ReactiveProgram t m)+ deriving instance Monad m => Applicative (ReactiveProgram t m)+ deriving instance Monad m => Monad (ReactiveProgram t m)+ deriving instance MonadFix m => MonadFix (ReactiveProgram t m)+ deriving instance MonadIO m => MonadIO (ReactiveProgram t m)+ deriving instance R.MonadSample t m => R.MonadSample t (ReactiveProgram t m)+ deriving instance R.MonadHold t m => R.MonadHold t (ReactiveProgram t m)+ deriving instance R.NotReady t m => R.NotReady t (ReactiveProgram t m)+ deriving instance R.PerformEvent t m => R.PerformEvent t (ReactiveProgram t m)+ deriving instance R.TriggerEvent t m => R.TriggerEvent t (ReactiveProgram t m)+ deriving instance R.PostBuild t m => R.PostBuild t (ReactiveProgram t m) instance (MonadFix m, R.MonadHold t m, R.Adjustable t m) => R.Adjustable t (ReactiveProgram t m) where- runWithReplace a0 a' =- ReactiveProgram $ R.runWithReplace (unReactiveProgram a0) $ fmap unReactiveProgram a'- traverseIntMapWithKeyWithAdjust f dm0 dm' =- ReactiveProgram $ R.traverseIntMapWithKeyWithAdjust (\k v -> unReactiveProgram (f k v)) dm0 dm'- traverseDMapWithKeyWithAdjust f dm0 dm' =- ReactiveProgram $ R.traverseDMapWithKeyWithAdjust (\k v -> unReactiveProgram (f k v)) dm0 dm'- traverseDMapWithKeyWithAdjustWithMove f dm0 dm' =- ReactiveProgram $ R.traverseDMapWithKeyWithAdjustWithMove (\k v -> unReactiveProgram (f k v)) dm0 dm'+ runWithReplace a0 a' =+ ReactiveProgram $ R.runWithReplace (unReactiveProgram a0) $ fmap unReactiveProgram a'+ traverseIntMapWithKeyWithAdjust f dm0 dm' =+ ReactiveProgram $ R.traverseIntMapWithKeyWithAdjust (\k v -> unReactiveProgram (f k v)) dm0 dm'+ traverseDMapWithKeyWithAdjust f dm0 dm' =+ ReactiveProgram $ R.traverseDMapWithKeyWithAdjust (\k v -> unReactiveProgram (f k v)) dm0 dm'+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' =+ ReactiveProgram $ R.traverseDMapWithKeyWithAdjustWithMove (\k v -> unReactiveProgram (f k v)) dm0 dm' -runReactiveProgram- :: (R.Reflex t, MonadFix m)- => ReactiveProgram t m ()- -> ReactiveInput t- -> m (R.Dynamic t Picture, R.Dynamic t Picture)+runReactiveProgram ::+ (R.Reflex t, MonadFix m) =>+ ReactiveProgram t m () ->+ ReactiveInput t ->+ m (R.Dynamic t Picture, R.Dynamic t Picture) runReactiveProgram (ReactiveProgram program) input = do- (_, output) <- R.runDynamicWriterT (runReaderT program input)- let pic = coalescePics . userPictures <$> output- let sysPic = (&) <$> (systemPicture <$> output)- <*> (userTransform <$> output <*> pic)- return (pic, sysPic)- where coalescePics [] = blank- coalescePics [p] = p- coalescePics ps = pictures ps+ (_, output) <- R.runDynamicWriterT (runReaderT program input)+ let pic = coalescePics . userPictures <$> output+ let sysPic =+ (&) <$> (systemPicture <$> output)+ <*> (userTransform <$> output <*> pic)+ return (pic, sysPic)+ where+ coalescePics [] = blank+ coalescePics [p] = p+ coalescePics ps = pictures ps -withReactiveInput- :: ReactiveInput t- -> (ReactiveProgram t m a -> ReactiveProgram t m a)-withReactiveInput input (ReactiveProgram program)- = ReactiveProgram (withReaderT (const input) program)+withReactiveInput ::+ ReactiveInput t ->+ (ReactiveProgram t m a -> ReactiveProgram t m a)+withReactiveInput input (ReactiveProgram program) =+ ReactiveProgram (withReaderT (const input) program) getReactiveInput :: Monad m => ReactiveProgram t m (ReactiveInput t) getReactiveInput = ReactiveProgram ask systemDraw :: (R.Reflex t, Monad m) => R.Dynamic t Picture -> ReactiveProgram t m ()-systemDraw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty { systemPicture = a })+systemDraw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty {systemPicture = a}) -transformUserPicture- :: (R.Reflex t, Monad m) => R.Dynamic t (Picture -> Picture) -> ReactiveProgram t m ()+transformUserPicture ::+ (R.Reflex t, Monad m) => R.Dynamic t (Picture -> Picture) -> ReactiveProgram t m () transformUserPicture =- ReactiveProgram . R.tellDyn . fmap (\a -> mempty { userTransform = a })+ ReactiveProgram . R.tellDyn . fmap (\a -> mempty {userTransform = a}) -- | Type class for the builder monad of a CodeWorld/Reflex app. class- (- R.Reflex t,+ ( R.Reflex t, R.Adjustable t m, R.MonadHold t m, R.NotReady t m,@@ -1813,35 +1839,37 @@ MonadFix m, MonadIO m, MonadIO (R.Performable m)- ) => ReflexCodeWorld t m | m -> t where- -- | Gets an Event of key presses. The event value is a logical key name.- getKeyPress :: m (R.Event t Text)+ ) =>+ ReflexCodeWorld t m+ | m -> t+ where+ -- | Gets an Event of key presses. The event value is a logical key name.+ getKeyPress :: m (R.Event t Text) - -- | Gets an Event of key presses. The event value is a logical key name.- getKeyRelease :: m (R.Event t Text)+ -- | Gets an Event of key presses. The event value is a logical key name.+ getKeyRelease :: m (R.Event t Text) - -- | Gets an Event of text entered. The event value is the typed text.- getTextEntry :: m (R.Event t Text)+ -- | Gets an Event of text entered. The event value is the typed text.+ getTextEntry :: m (R.Event t Text) - -- | Gets an event of pointer clicks. The event value is the location of- -- the click.- getPointerClick :: m (R.Event t Point)+ -- | Gets an event of pointer clicks. The event value is the location of+ -- the click.+ getPointerClick :: m (R.Event t Point) - -- | Gets the Dynamic position of the pointer.- getPointerPosition :: m (R.Dynamic t Point)+ -- | Gets the Dynamic position of the pointer.+ getPointerPosition :: m (R.Dynamic t Point) - -- | Gets a Dynamic indicator whether the pointer is held down.- isPointerDown :: m (R.Dynamic t Bool)+ -- | Gets a Dynamic indicator whether the pointer is held down.+ isPointerDown :: m (R.Dynamic t Bool) - -- | Gets an Event indicating the passage of time.- getTimePassing :: m (R.Event t Double)+ -- | Gets an Event indicating the passage of time.+ getTimePassing :: m (R.Event t Double) - -- | Emits a given Dynamic picture to be drawn to the screen.- draw :: R.Dynamic t Picture -> m ()+ -- | Emits a given Dynamic picture to be drawn to the screen.+ draw :: R.Dynamic t Picture -> m () instance- (- R.Reflex t,+ ( R.Reflex t, R.Adjustable t m, R.MonadHold t m, R.NotReady t m,@@ -1851,22 +1879,24 @@ MonadFix m, MonadIO m, MonadIO (R.Performable m)- ) => ReflexCodeWorld t (ReactiveProgram t m) where- getKeyPress = ReactiveProgram $ asks keyPress+ ) =>+ ReflexCodeWorld t (ReactiveProgram t m)+ where+ getKeyPress = ReactiveProgram $ asks keyPress - getKeyRelease = ReactiveProgram $ asks keyRelease+ getKeyRelease = ReactiveProgram $ asks keyRelease - getTextEntry = ReactiveProgram $ asks textEntry+ getTextEntry = ReactiveProgram $ asks textEntry - getPointerClick = ReactiveProgram $ asks pointerPress+ getPointerClick = ReactiveProgram $ asks pointerPress - getPointerPosition = ReactiveProgram $ asks pointerPosition+ getPointerPosition = ReactiveProgram $ asks pointerPosition - isPointerDown = ReactiveProgram $ asks pointerDown+ isPointerDown = ReactiveProgram $ asks pointerDown - getTimePassing = ReactiveProgram $ asks timePassing+ getTimePassing = ReactiveProgram $ asks timePassing - draw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty { userPictures = [a] })+ draw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty {userPictures = [a]}) gateDyn :: forall t a. R.Reflex t => R.Dynamic t Bool -> R.Event t a -> R.Event t a gateDyn dyn e = R.switchDyn (bool R.never e <$> dyn)@@ -1874,29 +1904,30 @@ type EventChannel t = Chan [DSum (R.EventTriggerRef t) R.TriggerInvocation] -- | Handle the event channel used with 'runTriggerEventT'.-asyncProcessEventTriggers- :: EventChannel t- -> R.FireCommand t (R.SpiderHost R.Global)- -> IO ThreadId+asyncProcessEventTriggers ::+ EventChannel t ->+ R.FireCommand t (R.SpiderHost R.Global) ->+ IO ThreadId asyncProcessEventTriggers events fireCommand = forkIO . forever $ do- -- Collect event triggers, and fire callbacks after propagation- eventsAndTriggers <- readChan events- eventsToFire <- flip wither eventsAndTriggers $- \(R.EventTriggerRef ref :=> R.TriggerInvocation a _) ->- fmap (==> a) <$> readRef ref- void . R.runSpiderHost $- R.runFireCommand fireCommand eventsToFire (pure ())- -- Run callbacks- traverse_ (\(_ :=> R.TriggerInvocation _ cb) -> cb) eventsAndTriggers+ -- Collect event triggers, and fire callbacks after propagation+ eventsAndTriggers <- readChan events+ eventsToFire <- flip wither eventsAndTriggers $+ \(R.EventTriggerRef ref :=> R.TriggerInvocation a _) ->+ fmap (==> a) <$> readRef ref+ void . R.runSpiderHost $+ R.runFireCommand fireCommand eventsToFire (pure ())+ -- Run callbacks+ traverse_ (\(_ :=> R.TriggerInvocation _ cb) -> cb) eventsAndTriggers -sendEvent- :: R.FireCommand t (R.SpiderHost R.Global)- -> IORef (Maybe (R.EventTrigger t a))- -> a- -> IO ()+sendEvent ::+ R.FireCommand t (R.SpiderHost R.Global) ->+ IORef (Maybe (R.EventTrigger t a)) ->+ a ->+ IO () sendEvent (R.FireCommand fire) triggerRef a =- R.runSpiderHost $ readRef triggerRef- >>= traverse_ (\t -> fire [t ==> a] (pure ()))+ R.runSpiderHost $+ readRef triggerRef+ >>= traverse_ (\t -> fire [t ==> a] (pure ())) #ifdef ghcjs_HOST_OS @@ -1957,7 +1988,7 @@ pointerDown <- R.holdDyn False $ R.leftmost [True <$ pointerPress, False <$ pointerRelease] - return ReactiveInput{..}+ return (ReactiveInput {..}) inspectLogicalInput :: forall t m. (R.Reflex t, R.MonadHold t m)@@ -2001,11 +2032,7 @@ ) => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture))) -> IO () runReactive program = do- showCanvas-- Just window <- currentWindow- Just doc <- currentDocument- Just canvas <- getElementById doc ("screen" :: JSString)+ canvas <- getCanvas setCanvasSize canvas canvas frameRenderer <- createFrameRenderer canvas@@ -2021,6 +2048,8 @@ (debugUpdate, debugUpdateTriggerRef) <- R.runSpiderHost R.newEventWithTriggerRef debugState <- R.runSpiderHost $ R.holdUniqDyn =<< R.foldDyn ($) debugStateInit debugUpdate + Just window <- currentWindow+ rec physicalInput <- R.runSpiderHost $ createPhysicalReactiveInput window canvas fireAndRedraw@@ -2099,7 +2128,7 @@ pointerDown <- R.runSpiderHost $ R.holdDyn False $ R.leftmost [True <$ pointerPress, False <$ pointerRelease] - let input = ReactiveInput{..}+ let input = ReactiveInput {..} triggeredEvents <- newChan (_, fireCommand) <- R.runSpiderHost $ R.hostPerformEventT $ do
src/CodeWorld/EntryPoints.hs view
@@ -8,7 +8,7 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -72,74 +72,48 @@ -- the state into a picture to display. (world -> Picture) -> IO ()-activityOf initial change picture =- interactionOf initial (const id) change picture---- | Runs an interactive event-driven CodeWorld program. This is a--- generalization of simulations that can respond to events like key presses--- and mouse movement.-interactionOf ::- -- | The initial state of the interaction.- world ->- -- | The time step function, which advances- -- the state given the time difference.- (Double -> world -> world) ->- -- | The event handling function, which updates- -- the state given a user interface event.- (Event -> world -> world) ->- -- | The visualization function, which converts- -- the state into a picture to display.- (world -> Picture) ->- IO ()-interactionOf initial step event draw = do+activityOf initial change picture = do hFlush stdout- runInspect initial step event draw draw-{-# WARNING- interactionOf- [ "Please use activityOf instead of interactionOf.",- "interactionOf may be removed July 2020."- ]- #-}+ runInspect initial (const id) change picture picture -data Timeline a- = Timeline- { past :: [a], -- reversed list of past states- present :: !a, -- present state- future :: [a] -- list of future states- }+data Timeline a = Timeline+ { past :: [a], -- reversed list of past states+ present :: !a, -- present state+ future :: [a] -- list of future states+ } newTimeline :: a -> Timeline a newTimeline x = Timeline [] x [] applyToTimeline :: (a -> a) -> Timeline a -> Timeline a-applyToTimeline f timeline@Timeline {..}+applyToTimeline f timeline@(Timeline {..}) | identical present new = timeline | otherwise = Timeline (present : past) new [] where new = f present undoTimeline :: Timeline a -> Timeline a-undoTimeline timeline@Timeline {..} = case past of+undoTimeline timeline@(Timeline {..}) = case past of [] -> timeline (x : xs) -> Timeline xs x (present : future) redoTimeline :: Timeline a -> Timeline a-redoTimeline timeline@Timeline {..} = case future of+redoTimeline timeline@(Timeline {..}) = case future of [] -> timeline (x : xs) -> Timeline (present : past) x xs restartTimeline :: Timeline a -> Timeline a-restartTimeline timeline@Timeline {..}+restartTimeline timeline@(Timeline {..}) | null past = timeline | otherwise = Timeline [] x (xs ++ present : future) where x : xs = reverse past timelineLength :: Timeline a -> Int-timelineLength Timeline {..} = length past + 1 + length future+timelineLength (Timeline {..}) = length past + 1 + length future travelToTime :: Double -> Timeline a -> Timeline a-travelToTime t timeline@Timeline {..}+travelToTime t timeline@(Timeline {..}) | diff >= 0 = iterate redoTimeline timeline !! diff | otherwise = iterate undoTimeline timeline !! (- diff) where@@ -148,7 +122,7 @@ diff = desiredPast - actualPast timelinePos :: Timeline a -> Double-timelinePos Timeline {..}+timelinePos (Timeline {..}) | null past && null future = 1 | otherwise = fromIntegral (length past) / fromIntegral (length past + length future) @@ -175,32 +149,32 @@ data StrictMaybe a = SNothing | SJust !a deriving (Functor, Show) -data Wrapped a- = Wrapped- { state :: a,- playbackSpeed :: !Double,- lastInteractionTime :: !Double,- zoomFactor :: !Double,- panCenter :: !StrictPoint,- panDraggingAnchor :: !(StrictMaybe StrictPoint),- isDraggingSpeed :: !Bool,- isDraggingHistory :: !Bool,- isDraggingZoom :: !Bool- }+data Wrapped a = Wrapped+ { state :: a,+ playbackSpeed :: !Double,+ lastInteractionTime :: !Double,+ zoomFactor :: !Double,+ panCenter :: !StrictPoint,+ panDraggingAnchor :: !(StrictMaybe StrictPoint),+ isDraggingSpeed :: !Bool,+ isDraggingHistory :: !Bool,+ isDraggingZoom :: !Bool+ } deriving (Show, Functor) wrappedInitial :: a -> Wrapped a-wrappedInitial w = Wrapped- { state = w,- playbackSpeed = 1,- lastInteractionTime = 1000,- zoomFactor = 1,- panCenter = SP 0 0,- panDraggingAnchor = SNothing,- isDraggingSpeed = False,- isDraggingHistory = False,- isDraggingZoom = False- }+wrappedInitial w =+ Wrapped+ { state = w,+ playbackSpeed = 1,+ lastInteractionTime = 1000,+ zoomFactor = 1,+ panCenter = SP 0 0,+ panDraggingAnchor = SNothing,+ isDraggingSpeed = False,+ isDraggingHistory = False,+ isDraggingZoom = False+ } identical :: a -> a -> Bool identical !x !y = isTrue# (reallyUnsafePtrEquality# x y)@@ -679,95 +653,6 @@ | playbackSpeed w == 0 = [PanningLayer] | otherwise = [] --- | Shows a simulation, which is essentially a continuous-time dynamical--- system described by an initial value and step function.-simulationOf ::- -- | The initial state of the simulation.- world ->- -- | The time step function, which advances- -- the state given the time difference.- (Double -> world -> world) ->- -- | The visualization function, which converts- -- the state into a picture to display.- (world -> Picture) ->- IO ()-simulationOf initial step draw = do- hFlush stdout- runInspect- (wrappedInitial initial)- (wrappedStep step)- (wrappedEvent simulationControls step (const id))- (wrappedDraw simulationControls draw)- (draw . state)-{-# WARNING- simulationOf- [ "Please use activityOf instead of simulationOf.",- "simulationOf may be removed July 2020."- ]- #-}--debugSimulationOf ::- -- | The initial state of the simulation.- world ->- -- | The time step function, which advances- -- the state given the time difference.- (Double -> world -> world) ->- -- | The visualization function, which converts- -- the state into a picture to display.- (world -> Picture) ->- IO ()-debugSimulationOf simInitial simStep simDraw = do- hFlush stdout- runInspect- (wrappedInitial initial)- (wrappedStep step)- (wrappedEvent statefulDebugControls step (const id))- (wrappedDraw statefulDebugControls draw)- (draw . state)- where- initial = newTimeline simInitial- step = applyToTimeline . simStep- draw = simDraw . present-{-# WARNING- debugSimulationOf- [ "Please use debugActivityOf instead of debugSimulationOf.",- "debugSimulationOf may be removed July 2020."- ]- #-}--debugInteractionOf ::- -- | The initial state of the interaction.- world ->- -- | The time step function, which advances- -- the state given the time difference.- (Double -> world -> world) ->- -- | The event handling function, which updates- -- the state given a user interface event.- (Event -> world -> world) ->- -- | The visualization function, which converts- -- the state into a picture to display.- (world -> Picture) ->- IO ()-debugInteractionOf baseInitial baseStep baseEvent baseDraw = do- hFlush stdout- runInspect- (wrappedInitial initial)- (wrappedStep step)- (wrappedEvent statefulDebugControls step event)- (wrappedDraw statefulDebugControls draw)- (draw . state)- where- initial = newTimeline baseInitial- step = applyToTimeline . baseStep- event = applyToTimeline . baseEvent- draw = baseDraw . present-{-# WARNING- debugInteractionOf- [ "Please use debugActivityOf instead of debugInteractionOf.",- "debugInteractionOf may be removed July 2020."- ]- #-}- -- | A version of 'activityOf' which runs an interactive CodeWorld program -- in debugging mode. In this mode, the program gets controls to pause and -- manipulate time, and even go back in time to look at past states.@@ -781,8 +666,14 @@ -- the state into a picture to display. (world -> Picture) -> IO ()-debugActivityOf initial change picture =- debugInteractionOf initial (const id) change picture+debugActivityOf initial change picture = do+ hFlush stdout+ runInspect+ (wrappedInitial (newTimeline initial))+ (wrappedStep (const id))+ (wrappedEvent statefulDebugControls (const id) (applyToTimeline . change))+ (wrappedDraw statefulDebugControls (picture . present))+ (picture . present . state) -- | Runs an interactive multi-user CodeWorld program that is joined by several -- participants over the internet.@@ -846,82 +737,11 @@ -- and the state into a picture to display. (Int -> world -> Picture) -> IO ()-unsafeGroupActivityOf numPlayers initial event draw =- unsafeCollaborationOf numPlayers initial (const id) event draw---- | A version of 'collaborationOf' that avoids static pointers, and does not--- check for consistent parameters.-unsafeCollaborationOf ::- -- | The number of participants to expect. The participants will be- -- numbered starting at 0.- Int ->- -- | The initial state of the collaboration.- (StdGen -> world) ->- -- | The time step function, which advances the state given the time- -- difference.- (Double -> world -> world) ->- -- | The event handling function, which updates the state given a- -- participant number and user interface event.- (Int -> Event -> world -> world) ->- -- | The visualization function, which converts a participant number- -- and the state into a picture to display.- (Int -> world -> Picture) ->- IO ()-unsafeCollaborationOf numPlayers initial step event draw = do+unsafeGroupActivityOf numPlayers initial event draw = do hFlush stdout dhash <- getDeployHash let token = PartialToken dhash- runGame token numPlayers initial step event draw-{-# WARNING- unsafeCollaborationOf- [ "Please use unsafeGroupActivityOf instead of unsafeCollaborationOf.",- "unsafeCollaborationOf may be removed July 2020."- ]- #-}---- | Runs an interactive multi-user CodeWorld program, involving multiple--- participants over the internet.-collaborationOf ::- -- | The number of participants to expect. The participants will be- -- numbered starting at 0.- Int ->- -- | The initial state of the collaboration.- StaticPtr (StdGen -> world) ->- -- | The time step function, which advances the state given the time- -- difference.- StaticPtr (Double -> world -> world) ->- -- | The event handling function, which updates the state given a- -- participant number and user interface event.- StaticPtr (Int -> Event -> world -> world) ->- -- | The visualization function, which converts a participant number- -- and the state into a picture to display.- StaticPtr (Int -> world -> Picture) ->- IO ()-collaborationOf numPlayers initial step event draw = do- hFlush stdout- dhash <- getDeployHash- let token =- FullToken- { tokenDeployHash = dhash,- tokenNumPlayers = numPlayers,- tokenInitial = staticKey initial,- tokenStep = staticKey step,- tokenEvent = staticKey event,- tokenDraw = staticKey draw- }- runGame- token- numPlayers- (deRefStaticPtr initial)- (deRefStaticPtr step)- (deRefStaticPtr event)- (deRefStaticPtr draw)-{-# WARNING- collaborationOf- [ "Please use groupActivityOf instead of collaborationOf.",- "collaborationOf may be removed July 2020."- ]- #-}+ runGame token numPlayers initial (const id) event draw -- | 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
src/CodeWorld/Event.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/CodeWorld/Image.hs view
@@ -1,5 +1,5 @@ {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/CodeWorld/Parameter.hs view
@@ -5,7 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/CodeWorld/Picture.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -56,7 +56,8 @@ -- point horizontally across the y axis. reflectedPoint :: Double -> Point -> Point reflectedPoint th (x, y) = (x * cos a + y * sin a, x * sin a - y * cos a)- where a = 2 * th+ where+ a = 2 * th -- | Scales a given point by given x and y scaling factor. Scaling by a -- negative factor also reflects across that axis.@@ -82,7 +83,7 @@ -- >>> vectorLength (10, 10) -- 14.14 vectorLength :: Vector -> Double-vectorLength (x, y) = sqrt (x*x + y*y)+vectorLength (x, y) = sqrt (x * x + y * y) -- | The counter-clockwise angle, in radians, that a given vector make with the X-axis --@@ -118,7 +119,7 @@ -- (6.123233995736766e-17, 1.0) rotatedVector :: Double -> Vector -> Vector rotatedVector angle (x, y) =- (x * cos angle - y * sin angle, x * sin angle + y * cos angle)+ (x * cos angle - y * sin angle, x * sin angle + y * cos angle) -- | The dot product of two vectors dotProduct :: Vector -> Vector -> Double@@ -134,50 +135,53 @@ -- Ultimately, a picture can be drawn on the screen using one of the -- CodeWorld entry points such as 'drawingOf'. data Picture- = SolidPolygon (Maybe SrcLoc) [Point]- | SolidClosedCurve (Maybe SrcLoc) [Point]- | Polygon (Maybe SrcLoc) [Point]- | ThickPolygon (Maybe SrcLoc) [Point] !Double- | Rectangle (Maybe SrcLoc) !Double !Double- | SolidRectangle (Maybe SrcLoc) !Double !Double- | ThickRectangle (Maybe SrcLoc) !Double !Double !Double- | ClosedCurve (Maybe SrcLoc) [Point]- | ThickClosedCurve (Maybe SrcLoc) [Point] !Double- | Polyline (Maybe SrcLoc) [Point]- | ThickPolyline (Maybe SrcLoc) [Point] !Double- | Curve (Maybe SrcLoc) [Point]- | ThickCurve (Maybe SrcLoc) [Point] !Double- | Circle (Maybe SrcLoc) !Double- | SolidCircle (Maybe SrcLoc) !Double- | ThickCircle (Maybe SrcLoc) !Double !Double- | Sector (Maybe SrcLoc) !Double !Double !Double- | Arc (Maybe SrcLoc) !Double !Double !Double- | ThickArc (Maybe SrcLoc) !Double !Double !Double !Double- | StyledLettering (Maybe SrcLoc) !TextStyle !Font !Text- | Lettering (Maybe SrcLoc) !Text- | Color (Maybe SrcLoc) !Color !Picture- | Translate (Maybe SrcLoc) !Double !Double !Picture- | Scale (Maybe SrcLoc) !Double !Double !Picture- | Dilate (Maybe SrcLoc) !Double !Picture- | Rotate (Maybe SrcLoc) !Double !Picture- | Reflect (Maybe SrcLoc) !Double !Picture- | Clip (Maybe SrcLoc) !Double !Double !Picture- | CoordinatePlane (Maybe SrcLoc)- | Sketch (Maybe SrcLoc) !Text !Text !Double !Double- | Pictures (Maybe SrcLoc) [Picture]- | PictureAnd (Maybe SrcLoc) [Picture]- | Blank (Maybe SrcLoc)- deriving (Generic)+ = SolidPolygon (Maybe SrcLoc) [Point]+ | SolidClosedCurve (Maybe SrcLoc) [Point]+ | Polygon (Maybe SrcLoc) [Point]+ | ThickPolygon (Maybe SrcLoc) [Point] !Double+ | Rectangle (Maybe SrcLoc) !Double !Double+ | SolidRectangle (Maybe SrcLoc) !Double !Double+ | ThickRectangle (Maybe SrcLoc) !Double !Double !Double+ | ClosedCurve (Maybe SrcLoc) [Point]+ | ThickClosedCurve (Maybe SrcLoc) [Point] !Double+ | Polyline (Maybe SrcLoc) [Point]+ | ThickPolyline (Maybe SrcLoc) [Point] !Double+ | Curve (Maybe SrcLoc) [Point]+ | ThickCurve (Maybe SrcLoc) [Point] !Double+ | Circle (Maybe SrcLoc) !Double+ | SolidCircle (Maybe SrcLoc) !Double+ | ThickCircle (Maybe SrcLoc) !Double !Double+ | Sector (Maybe SrcLoc) !Double !Double !Double+ | Arc (Maybe SrcLoc) !Double !Double !Double+ | ThickArc (Maybe SrcLoc) !Double !Double !Double !Double+ | StyledLettering (Maybe SrcLoc) !TextStyle !Font !Text+ | Lettering (Maybe SrcLoc) !Text+ | Color (Maybe SrcLoc) !Color !Picture+ | Translate (Maybe SrcLoc) !Double !Double !Picture+ | Scale (Maybe SrcLoc) !Double !Double !Picture+ | Dilate (Maybe SrcLoc) !Double !Picture+ | Rotate (Maybe SrcLoc) !Double !Picture+ | Reflect (Maybe SrcLoc) !Double !Picture+ | Clip (Maybe SrcLoc) !Double !Double !Picture+ | CoordinatePlane (Maybe SrcLoc)+ | Sketch (Maybe SrcLoc) !Text !Text !Double !Double+ | Pictures (Maybe SrcLoc) [Picture]+ | PictureAnd (Maybe SrcLoc) [Picture]+ | Blank (Maybe SrcLoc)+ deriving (Generic) instance NFData Picture -- A style in which to draw lettering. Either 'Plain', 'Bold', or -- 'Italic' data TextStyle- = Plain -- ^ Plain letters with no style- | Bold -- ^ Heavy, thick lettering used for emphasis- | Italic -- ^ Slanted script-like lettering used for emphasis- deriving (Generic, Show)+ = -- | Plain letters with no style+ Plain+ | -- | Heavy, thick lettering used for emphasis+ Bold+ | -- | Slanted script-like lettering used for emphasis+ Italic+ deriving (Generic, Show) instance NFData TextStyle @@ -188,13 +192,13 @@ -- installed on the computer running your program, a different font -- may be used instead. data Font- = SansSerif- | Serif- | Monospace- | Handwriting- | Fancy- | NamedFont !Text- deriving (Generic, Show)+ = SansSerif+ | Serif+ | Monospace+ | Handwriting+ | Fancy+ | NamedFont !Text+ deriving (Generic, Show) instance NFData Font @@ -206,24 +210,10 @@ polyline :: HasCallStack => [Point] -> Picture polyline ps = Polyline (getDebugSrcLoc callStack) ps --- | A thin sequence of line segments, with these points as endpoints-path :: HasCallStack => [Point] -> Picture-path ps = Polyline (getDebugSrcLoc callStack) ps--{-# WARNING path ["Please use polyline instead of path.",- "path may be removed July 2020."] #-}- -- | A thick sequence of line segments, with given line width and endpoints thickPolyline :: HasCallStack => Double -> [Point] -> Picture thickPolyline n ps = ThickPolyline (getDebugSrcLoc callStack) ps n --- | A thick sequence of line segments, with given line width and endpoints-thickPath :: HasCallStack => Double -> [Point] -> Picture-thickPath n ps = ThickPolyline (getDebugSrcLoc callStack) ps n--{-# WARNING thickPath ["Please used thickPolyline instead of thickPath.",- "thickPath may be removed July 2020."] #-}- -- | A thin polygon with these points as vertices polygon :: HasCallStack => [Point] -> Picture polygon ps = Polygon (getDebugSrcLoc callStack) ps@@ -258,7 +248,7 @@ solidClosedCurve ps = SolidClosedCurve (getDebugSrcLoc callStack) ps rectangleVertices :: Double -> Double -> [Point]-rectangleVertices w h = [ (w / 2, h / 2), (w / 2, -h / 2), (-w / 2, -h / 2), (-w / 2, h / 2) ]+rectangleVertices w h = [(w / 2, h / 2), (w / 2, - h / 2), (- w / 2, - h / 2), (- w / 2, h / 2)] -- | A thin rectangle, with this width and height rectangle :: HasCallStack => Double -> Double -> Picture@@ -305,23 +295,9 @@ sector = Sector (getDebugSrcLoc callStack) -- | A rendering of text characters.-text :: HasCallStack => Text -> Picture-text = Lettering (getDebugSrcLoc callStack)--{-# WARNING text ["Please used lettering instead of text.",- "text may be removed July 2020."] #-}---- | A rendering of text characters. lettering :: HasCallStack => Text -> Picture lettering = Lettering (getDebugSrcLoc callStack) --- | A rendering of text characters, with a specific choice of font and style.-styledText :: HasCallStack => TextStyle -> Font -> Text -> Picture-styledText = StyledLettering (getDebugSrcLoc callStack)--{-# WARNING styledText ["Please used styledLettering instead of styledText.",- "styledText may be removed July 2020."] #-}- -- | A rendering of text characters onto a Picture, with a specific -- choice of font and style. styledLettering :: HasCallStack => TextStyle -> Font -> Text -> Picture@@ -372,17 +348,19 @@ -- | Binary composition of pictures. (&) :: HasCallStack => Picture -> Picture -> Picture+ infixr 0 & a & PictureAnd loc2 bs- | srcContains loc1 loc2 = PictureAnd loc1 (a:bs)- where loc1 = getDebugSrcLoc callStack+ | srcContains loc1 loc2 = PictureAnd loc1 (a : bs)+ where+ loc1 = getDebugSrcLoc callStack a & b = PictureAnd (getDebugSrcLoc callStack) [a, b] instance Monoid Picture where- mempty = blank- mappend = (&)- mconcat = pictures+ mempty = blank+ mappend = (&)+ mconcat = pictures #if MIN_VERSION_base(4,11,0) @@ -405,22 +383,27 @@ -- | The CodeWorld logo. codeWorldLogo :: HasCallStack => Picture codeWorldLogo =- Sketch- (getDebugSrcLoc callStack)- "codeWorldLogo"- $(embedAsUrl "image/svg+xml" "data/codeworld.svg")- 17.68 7.28+ Sketch+ (getDebugSrcLoc callStack)+ "codeWorldLogo"+ $(embedAsUrl "image/svg+xml" "data/codeworld.svg")+ 17.68+ 7.28 -- | An image from a standard image format. The image can be any universally -- supported format, including SVG, PNG, JPG, etc. SVG should be preferred, as -- it behaves better with transformations.-image- :: HasCallStack- => Text -- ^ Name for the picture, used for debugging- -> Text -- ^ Data-scheme URI for the image data- -> Double -- ^ Width, in CodeWorld screen units- -> Double -- ^ Height, in CodeWorld screen units- -> Picture+image ::+ HasCallStack =>+ -- | Name for the picture, used for debugging+ Text ->+ -- | Data-scheme URI for the image data+ Text ->+ -- | Width, in CodeWorld screen units+ Double ->+ -- | Height, in CodeWorld screen units+ Double ->+ Picture image = Sketch (getDebugSrcLoc callStack) getDebugSrcLoc :: CallStack -> Maybe SrcLoc@@ -432,8 +415,9 @@ srcContains Nothing _ = False srcContains _ Nothing = True srcContains (Just a) (Just b) =- srcLocFile a == srcLocFile b && srcLocStartLine a < srcLocStartLine b ||- (srcLocStartLine a == srcLocStartLine b &&- srcLocStartCol a <= srcLocStartCol b) &&- srcLocEndLine a > srcLocEndLine b ||- (srcLocEndLine a == srcLocEndLine b && srcLocEndCol a >= srcLocEndCol b)+ srcLocFile a == srcLocFile b && srcLocStartLine a < srcLocStartLine b+ || ( srcLocStartLine a == srcLocStartLine b+ && srcLocStartCol a <= srcLocStartCol b+ )+ && srcLocEndLine a > srcLocEndLine b+ || (srcLocEndLine a == srcLocEndLine b && srcLocEndCol a >= srcLocEndCol b)
src/CodeWorld/Reflex.hs view
@@ -5,7 +5,7 @@ {-# LANGUAGE RecursiveDo #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.@@ -143,7 +143,7 @@ -- When using this module, you can build pictures using the same combinators as -- the main 'CodeWorld' module. However, the way you handle user input and draw -- to the screen is different. The 'ReflexCodeWorld' constraint gives you a--- a monad that has access to Reflex versions of input, such as keys, the mouse+-- monad that has access to Reflex versions of input, such as keys, the mouse -- pointer, and the time. Based on these inputs, you'll use 'draw' to draw -- output to the screen. --@@ -165,16 +165,15 @@ logicalInputs <- makeLogicalInputs controlState =<< getReactiveInput withReactiveInput logicalInputs program -data ControlState t- = ControlState- { csRunning :: Dynamic t Bool,- csTimeDilation :: Dynamic t Double,- csPointTransform :: Dynamic t (Point -> Point),- csSyntheticStep :: Event t ()- }+data ControlState t = ControlState+ { csRunning :: Dynamic t Bool,+ csTimeDilation :: Dynamic t Double,+ csPointTransform :: Dynamic t (Point -> Point),+ csSyntheticStep :: Event t ()+ } makeLogicalInputs :: (Reflex t, MonadHold t m) => ControlState t -> ReactiveInput t -> m (ReactiveInput t)-makeLogicalInputs ControlState {..} input = do+makeLogicalInputs (ControlState {..}) input = do keyPress <- return $ gateDyn csRunning $ keyPress input keyRelease <- return $ gateDyn csRunning $ keyRelease input textEntry <- return $ gateDyn csRunning $ textEntry input@@ -189,7 +188,7 @@ [ gateDyn csRunning $ attachWith (*) (current csTimeDilation) (timePassing input), 0.1 <$ csSyntheticStep ]- return ReactiveInput {..}+ return (ReactiveInput {..}) freezeDyn :: (Reflex t, MonadHold t m) => Dynamic t Bool -> Dynamic t a -> m (Dynamic t a) freezeDyn predicate dyn = do@@ -231,12 +230,13 @@ stepClick <- stepButton hoverAlpha (-2, -9) running transformUserPicture $ uncurry translated <$> panOffset transformUserPicture $ dilated <$> zoomFactor- return $ ControlState- { csRunning = running,- csTimeDilation = speedFactor,- csPointTransform = transformPoint <$> zoomFactor <*> panOffset,- csSyntheticStep = stepClick- }+ return $+ ControlState+ { csRunning = running,+ csTimeDilation = speedFactor,+ csPointTransform = transformPoint <$> zoomFactor <*> panOffset,+ csSyntheticStep = stepClick+ } where transformPoint z (dx, dy) (x, y) = ((x - dx) / z, (y - dy) / z)
src/CodeWorld/Sketches.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License.
src/Util/EmbedAsUrl.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.
test/Main.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE BangPatterns #-} {-- Copyright 2019 The CodeWorld Authors. All rights reserved.+ Copyright 2020 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.