codeworld-api 0.2.3 → 0.2.4
raw patch · 8 files changed
+564/−408 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- CodeWorld: fromHSL :: Double -> Double -> Double -> Color
- CodeWorld: loop :: HasCallStack => [Point] -> Picture
- CodeWorld: solidLoop :: HasCallStack => [Point] -> Picture
- CodeWorld: thickLoop :: HasCallStack => Double -> [Point] -> Picture
+ CodeWorld: TimePassing :: !Double -> Event
+ CodeWorld: activityOf :: world -> (Event -> world -> world) -> (world -> Picture) -> IO ()
+ CodeWorld: dilatedPoint :: Double -> Point -> Point
+ CodeWorld: groupActivityOf :: Int -> StaticPtr (StdGen -> world) -> StaticPtr (Int -> Event -> world -> world) -> StaticPtr (Int -> world -> Picture) -> IO ()
+ CodeWorld: lettering :: HasCallStack => Text -> Picture
+ CodeWorld: rotatedPoint :: Double -> Point -> Point
+ CodeWorld: scaledPoint :: Double -> Double -> Point -> Point
+ CodeWorld: styledLettering :: HasCallStack => TextStyle -> Font -> Text -> Picture
+ CodeWorld: translatedPoint :: Double -> Double -> Point -> Point
+ CodeWorld: unsafeGroupActivityOf :: Int -> (StdGen -> world) -> (Int -> Event -> world -> world) -> (Int -> world -> Picture) -> IO ()
- CodeWorld: (<>) :: Monoid m => m -> m -> m
+ CodeWorld: (<>) :: Semigroup a => a -> a -> a
Files
- codeworld-api.cabal +2/−2
- src/CodeWorld.hs +9/−4
- src/CodeWorld/CanvasM.hs +12/−6
- src/CodeWorld/CollaborationUI.hs +15/−14
- src/CodeWorld/Color.hs +31/−28
- src/CodeWorld/Driver.hs +384/−268
- src/CodeWorld/Event.hs +11/−4
- src/CodeWorld/Picture.hs +100/−82
codeworld-api.cabal view
@@ -1,5 +1,5 @@ Name: codeworld-api-Version: 0.2.3+Version: 0.2.4 Synopsis: Graphics library for CodeWorld License: Apache License-file: LICENSE@@ -54,4 +54,4 @@ Exposed: True Ghc-options: -O2- -Werror=incomplete-patterns+ -Wincomplete-patterns
src/CodeWorld.hs view
@@ -19,6 +19,9 @@ -- * Entry points drawingOf , animationOf+ , activityOf+ , groupActivityOf+ , unsafeGroupActivityOf , simulationOf , interactionOf , collaborationOf@@ -38,11 +41,8 @@ , curve , thickCurve , closedCurve- , loop , thickClosedCurve- , thickLoop , solidClosedCurve- , solidLoop , rectangle , solidRectangle , thickRectangle@@ -53,7 +53,9 @@ , sector , thickArc , text+ , lettering , styledText+ , styledLettering , colored , coloured , translated@@ -66,6 +68,10 @@ , coordinatePlane , codeWorldLogo , Point+ , translatedPoint+ , rotatedPoint+ , scaledPoint+ , dilatedPoint , Vector , vectorLength , vectorDirection@@ -113,7 +119,6 @@ , saturation , luminosity , alpha- , fromHSL -- * Events , Event(..) , MouseButton(..)
src/CodeWorld/CanvasM.hs view
@@ -22,7 +22,7 @@ import Control.Monad import Control.Monad.Reader-import Control.Monad.Trans (liftIO)+import Control.Monad.Trans (MonadIO) import Data.Text (Text, pack) #ifdef ghcjs_HOST_OS@@ -50,7 +50,7 @@ Double -> Double -> Double -> Double -> Double -> Double -> m () translate :: Double -> Double -> m () scale :: Double -> Double -> m ()- newImage :: Int -> Int -> m () -> m (Image m)+ newImage :: Int -> Int -> m a -> m (Image m, a) drawImage :: Image m -> Int -> Int -> Int -> Int -> m () globalCompositeOperation :: Text -> m () lineWidth :: Double -> m ()@@ -89,6 +89,9 @@ { unCanvasM :: Canvas.Context -> IO a } deriving (Functor) +runCanvasM :: Canvas.Context -> CanvasM a -> IO a+runCanvasM = flip unCanvasM+ instance Applicative CanvasM where pure x = CanvasM (const (return x)) f <*> x = CanvasM (\ctx -> unCanvasM f ctx <*> unCanvasM x ctx)@@ -106,6 +109,9 @@ foreign import javascript "$r = $3.isPointInStroke($1, $2);" js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool +instance MonadIO CanvasM where+ liftIO = CanvasM . const+ instance MonadCanvas CanvasM where type Image CanvasM = Canvas.Canvas save = CanvasM Canvas.save@@ -118,8 +124,8 @@ const $ do buf <- Canvas.create w h ctx <- Canvas.getContext buf- unCanvasM m ctx- return buf+ a <- unCanvasM m ctx+ return (buf, a) drawImage (Canvas.Canvas c) x y w h = CanvasM (Canvas.drawImage (Canvas.Image c) x y w h) globalCompositeOperation op =@@ -159,8 +165,8 @@ scale x y = Canvas.scale (x, y) newImage w h m = do ctx <- Canvas.newCanvas (w, h)- Canvas.with ctx m- return ctx+ a <- Canvas.with ctx m+ return (ctx, a) drawImage img x y w h = Canvas.drawImageSize ( img
src/CodeWorld/CollaborationUI.hs view
@@ -124,7 +124,7 @@ -- | Handling a UI event. May change the phase. event :: Event -> UIState s -> Step UIState s-event (MouseMovement p) s = continueUIState (setMousePos p s)+event (PointerMovement p) s = continueUIState (setMousePos p s) event CreateClick (MainMenu t p) = Create (Connecting t p) event JoinClick (MainMenu t p) = ContinueMain (Joining t p "") event (LetterPress k) (Joining t p code)@@ -139,13 +139,13 @@ event _ s = continueUIState s pattern CreateClick <-- MousePress LeftButton (inButton 0 1.5 8 2 -> True)+ PointerPress (inButton 0 1.5 8 2 -> True) pattern JoinClick <-- MousePress LeftButton (inButton 0 (-1.5) 8 2 -> True)+ PointerPress (inButton 0 (-1.5) 8 2 -> True) pattern ConnectClick <-- MousePress LeftButton (inButton 0 (-3.0) 8 2 -> True)+ PointerPress (inButton 0 (-3.0) 8 2 -> True) pattern LetterPress c <- (isLetterPress -> Just c) @@ -161,7 +161,7 @@ isCancelClick :: Event -> Bool isCancelClick (KeyPress "Esc") = True-isCancelClick (MousePress LeftButton point) = inButton 0 (-3) 8 2 point+isCancelClick (PointerPress point) = inButton 0 (-3) 8 2 point isCancelClick _ = False picture :: UIState s -> Picture@@ -242,13 +242,14 @@ size = 1 connectScreen :: Text -> Double -> Picture-connectScreen hdr t =- translated 0 7 connectBox & translated 0 (-7) codeWorldLogo &- colored (RGBA 0.85 0.86 0.9 1) (solidRectangle 20 20)+connectScreen hdr t = translated 0 (-7) connectBox+ & translated 0 2.5 (colored background (solidRectangle 20 3.5))+ & translated 0 5 codeWorldLogo+ & colored background (solidRectangle 20 20) where- connectBox =- scaled 2 2 (text hdr) & rectangle 14 3 &- colored connectColor (solidRectangle 14 3)- connectColor =- let k = (1 + sin (3 * t)) / 5- in HSL (k + 0.5) 0.8 0.7+ connectBox = scaled 2 2 (text hdr)+ & rectangle 14 3+ & colored connectColor (solidRectangle 14 3)+ connectColor = let k = (1 + sin (3 * t)) / 5+ in HSL (k + 0.5) 0.8 0.7+ background = RGBA 0.85 0.86 0.9 1
src/CodeWorld/Color.hs view
@@ -71,10 +71,6 @@ | h * 3 < 2 = m1 + (m2 - m1) * (2 / 3 - h) * 6 | otherwise = m1 -{-# WARNING-fromHSL "Please use HSL instead of fromHSL."- #-}- toHSL :: Color -> Maybe (Double, Double, Double) toHSL c@(RGBA _ _ _ 1) = Just (hue c, saturation c, luminosity c) toHSL _ = Nothing@@ -86,34 +82,34 @@ -- Primary and secondary colors red, green, blue, cyan, magenta, yellow :: Color-red = fromHSL (0 / 3 * pi) 0.75 0.5+red = HSL (0 / 3 * pi) 0.75 0.5 -yellow = fromHSL (1 / 3 * pi) 0.75 0.5+yellow = HSL (1 / 3 * pi) 0.75 0.5 -green = fromHSL (2 / 3 * pi) 0.75 0.5+green = HSL (2 / 3 * pi) 0.75 0.5 -cyan = fromHSL (3 / 3 * pi) 0.75 0.5+cyan = HSL (3 / 3 * pi) 0.75 0.5 -blue = fromHSL (4 / 3 * pi) 0.75 0.5+blue = HSL (4 / 3 * pi) 0.75 0.5 -magenta = fromHSL (5 / 3 * pi) 0.75 0.5+magenta = HSL (5 / 3 * pi) 0.75 0.5 -- Tertiary colors orange, rose, chartreuse, aquamarine, violet, azure :: Color-orange = fromHSL (1 / 6 * pi) 0.75 0.5+orange = HSL (1 / 6 * pi) 0.75 0.5 -chartreuse = fromHSL (3 / 6 * pi) 0.75 0.5+chartreuse = HSL (3 / 6 * pi) 0.75 0.5 -aquamarine = fromHSL (5 / 6 * pi) 0.75 0.5+aquamarine = HSL (5 / 6 * pi) 0.75 0.5 -azure = fromHSL (7 / 6 * pi) 0.75 0.5+azure = HSL (7 / 6 * pi) 0.75 0.5 -violet = fromHSL (9 / 6 * pi) 0.75 0.5+violet = HSL (9 / 6 * pi) 0.75 0.5 -rose = fromHSL (11 / 6 * pi) 0.75 0.5+rose = HSL (11 / 6 * pi) 0.75 0.5 -- Other common colors and color names-brown = fromHSL (1 / 6 * pi) 0.5 0.5+brown = HSL (1 / 6 * pi) 0.5 0.5 purple = violet @@ -137,7 +133,7 @@ lighter :: Double -> Color -> Color lighter d c =- sameAlpha c $ fromHSL (hue c) (saturation c) (fence (luminosity c + d))+ sameAlpha c $ HSL (hue c) (saturation c) (fence (luminosity c + d)) light :: Color -> Color light = lighter 0.15@@ -150,7 +146,7 @@ brighter :: Double -> Color -> Color brighter d c =- sameAlpha c $ fromHSL (hue c) (fence (saturation c + d)) (luminosity c)+ sameAlpha c $ HSL (hue c) (fence (saturation c + d)) (luminosity c) bright :: Color -> Color bright = brighter 0.25@@ -171,16 +167,23 @@ -- | An infinite list of colors. assortedColors :: [Color]-assortedColors = red : green : blue : more+assortedColors = [ HSL (adjusted h) 0.75 0.5 | h <- [0, 2 * pi / phi ..] ] where- more =- [ fromHSL hue 0.75 0.5- | denom <- doublesOf 6- , numer <- shuffleSeed denom [1,3 .. denom]- , let hue = fromIntegral numer * 2 * pi / fromIntegral denom- ]- doublesOf n = n : doublesOf (2 * n)- shuffleSeed k xs = shuffle' xs (length xs) (mkStdGen k)+ phi = (1 + sqrt 5) / 2+ adjusted x = x + a0+ + a1 * sin (1*x) + b1 * cos (1*x)+ + a2 * sin (2*x) + b2 * cos (2*x)+ + a3 * sin (3*x) + b3 * cos (3*x)+ + a4 * sin (4*x) + b4 * cos (4*x)+ a0 = -8.6870353473225553e-02+ a1 = 8.6485747604766350e-02+ b1 = -9.6564816819163041e-02+ a2 = -3.0072759267059756e-03+ b2 = 1.5048456422494966e-01+ a3 = 9.3179137558373148e-02+ b3 = 2.9002513227535595e-03+ a4 = -6.6275768228887290e-03+ b4 = -1.0451841243520298e-02 hue :: Color -> Double hue (fenceColor -> RGBA r g b a)
src/CodeWorld/Driver.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StaticPointers #-} {-# LANGUAGE DataKinds #-} {-@@ -30,6 +31,9 @@ module CodeWorld.Driver ( drawingOf , animationOf+ , activityOf+ , groupActivityOf+ , unsafeGroupActivityOf , simulationOf , interactionOf , collaborationOf@@ -39,6 +43,7 @@ import CodeWorld.CollaborationUI (SetupPhase(..), Step(..), UIState) import qualified CodeWorld.CollaborationUI as CUI+import qualified CodeWorld.CanvasM as CM import CodeWorld.Color import CodeWorld.Event import CodeWorld.Picture@@ -49,7 +54,7 @@ import Control.Monad import Control.Monad.Trans (liftIO) import Data.Char (chr)-import Data.List (find, zip4)+import Data.List (find, zip4, intercalate) import Data.Maybe (fromMaybe, isNothing, mapMaybe) import Data.Monoid import Data.Serialize@@ -67,8 +72,10 @@ import System.IO.Unsafe import System.Mem.StableName import System.Random+import Text.Printf import Text.Read #ifdef ghcjs_HOST_OS+import CodeWorld.CanvasM (CanvasM, runCanvasM) import CodeWorld.Message import CodeWorld.Prediction import qualified Control.Monad.Trans.State as State@@ -87,7 +94,7 @@ import GHCJS.DOM.MouseEvent import GHCJS.DOM.NonElementParentNode import GHCJS.DOM.Types (Element, unElement)-import GHCJS.DOM.Window as Window+import qualified GHCJS.DOM.Window as Window import GHCJS.Foreign import GHCJS.Foreign.Callback import GHCJS.Marshal@@ -120,6 +127,47 @@ -- frames, given the time in seconds. -> IO () +-- | Runs an interactive CodeWorld program that responds to events. Activities+-- can interact with the user, change over time, and remember information about+-- the past.+activityOf+ :: world -- ^ The initial state of the interaction.+ -> (Event -> world -> world) -- ^ The event handling function, which updates+ -- the state given an event.+ -> (world -> Picture) -- ^ The visualization function, which converts+ -- the state into a picture to display.+ -> IO ()++-- | Runs an interactive multi-user CodeWorld program that is joined by several+-- participants over the internet.+groupActivityOf+ :: Int -- ^ The number of participants to expect. The participants will be+ -- ^ numbered starting at 0.+ -> StaticPtr (StdGen -> world)+ -- ^ The initial state of the activity.+ -> StaticPtr (Int -> Event -> world -> world)+ -- ^ The event handling function, which updates the state given a+ -- participant number and user interface event.+ -> StaticPtr (Int -> world -> Picture)+ -- ^ The visualization function, which converts a participant number+ -- and the state into a picture to display.+ -> IO ()++-- | A version of 'groupActivityOf' that avoids static pointers, and does not+-- check for consistency.+unsafeGroupActivityOf+ :: Int -- ^ The number of participants to expect. The participants will be+ -- ^ numbered starting at 0.+ -> (StdGen -> world)+ -- ^ The initial state of the activity.+ -> (Int -> Event -> world -> world)+ -- ^ The event handling function, which updates the state given a+ -- participant number and user interface event.+ -> (Int -> world -> Picture)+ -- ^ The visualization function, which converts a participant number+ -- and the state into a picture to display.+ -> IO ()+ -- | Shows a simulation, which is essentially a continuous-time dynamical -- system described by an initial value and step function. simulationOf@@ -194,6 +242,14 @@ Drawing | Drawings [Drawing] +#if MIN_VERSION_base(4,11,0)++instance Semigroup Drawing where+ a <> Drawings bs = Drawings (a : bs)+ a <> b = Drawings [a, b]++#endif+ instance Monoid Drawing where mempty = Drawings [] mappend a (Drawings bs) = Drawings (a : bs)@@ -221,7 +277,7 @@ pictureToDrawing (ThickClosedCurve _ pts w) = Shape $ pathDrawer pts w True True pictureToDrawing (Circle _ r) = Shape $ arcDrawer 0 (2 * pi) r 0 pictureToDrawing (SolidCircle _ r) = Shape $ sectorDrawer 0 (2 * pi) r -pictureToDrawing (ThickCircle _ r lw) = Shape $ arcDrawer 0 (2 * pi) r lw+pictureToDrawing (ThickCircle _ lw r) = Shape $ arcDrawer 0 (2 * pi) r lw pictureToDrawing (Polyline _ pts) = Shape $ pathDrawer pts 0 False False pictureToDrawing (ThickPolyline _ pts w) = Shape $ pathDrawer pts w False False pictureToDrawing (Curve _ pts) = Shape $ pathDrawer pts 0 False True@@ -229,9 +285,9 @@ pictureToDrawing (Sector _ b e r) = Shape $ sectorDrawer b e r pictureToDrawing (Arc _ b e r) = Shape $ arcDrawer b e r 0 pictureToDrawing (ThickArc _ b e r w) = Shape $ arcDrawer b e r w-pictureToDrawing (Text _ txt) = Shape $ textDrawer Plain Serif txt+pictureToDrawing (Lettering _ txt) = Shape $ textDrawer Plain Serif txt pictureToDrawing (Blank _) = Drawings $ []-pictureToDrawing (StyledText _ sty fnt txt) = Shape $ textDrawer sty fnt txt+pictureToDrawing (StyledLettering _ sty fnt txt) = Shape $ textDrawer sty fnt txt pictureToDrawing (Logo _) = Shape $ logoDrawer pictureToDrawing (CoordinatePlane _) = Shape $ coordinatePlaneDrawer pictureToDrawing (Color _ col p) =@@ -240,6 +296,8 @@ Transformation (translateDS x y) $ pictureToDrawing p pictureToDrawing (Scale _ x y p) = Transformation (scaleDS x y) $ pictureToDrawing p+pictureToDrawing (Dilate _ k p) =+ Transformation (scaleDS k k) $ pictureToDrawing p pictureToDrawing (Rotate _ r p) = Transformation (rotateDS r) $ pictureToDrawing p pictureToDrawing (Pictures ps) = Drawings $ pictureToDrawing <$> ps@@ -307,6 +365,7 @@ | k <- [-9,-8 .. 9] , k /= 0 ]+ -------------------------------------------------------------------------------- -- GHCJS implementation of drawing #ifdef ghcjs_HOST_OS@@ -333,56 +392,47 @@ nextFrame :: IO Double nextFrame = waitForAnimationFrame >> getTime -withDS :: Canvas.Context -> DrawState -> IO () -> IO ()-withDS ctx (ta, tb, tc, td, te, tf, col) action = do- Canvas.save ctx- Canvas.transform ta tb tc td te tf ctx- Canvas.beginPath ctx+withDS :: DrawState -> CanvasM a -> CanvasM a+withDS (ta, tb, tc, td, te, tf, col) action = CM.saveRestore $ do+ CM.transform ta tb tc td te tf+ CM.beginPath action- Canvas.restore ctx -applyColor :: Canvas.Context -> DrawState -> IO ()-applyColor ctx ds =+applyColor :: DrawState -> CanvasM ()+applyColor ds = case getColorDS ds of Nothing -> do- Canvas.strokeStyle 0 0 0 1 ctx- Canvas.fillStyle 0 0 0 1 ctx+ CM.strokeColor 0 0 0 1+ CM.fillColor 0 0 0 1 Just (RGBA r g b a) -> do- Canvas.strokeStyle+ CM.strokeColor (round $ r * 255) (round $ g * 255) (round $ b * 255) a- ctx- Canvas.fillStyle+ CM.fillColor (round $ r * 255) (round $ g * 255) (round $ b * 255) a- ctx -foreign import javascript unsafe "$1.globalCompositeOperation = $2"- js_setGlobalCompositeOperation ::- Canvas.Context -> JSString -> IO ()- drawCodeWorldLogo ::- Canvas.Context -> DrawState -> Int -> Int -> Int -> Int -> IO ()-drawCodeWorldLogo ctx ds x y w h = do- Just doc <- currentDocument- Just canvas <- getElementById doc ("cwlogo" :: JSString)+ DrawState -> Int -> Int -> Int -> Int -> CanvasM ()+drawCodeWorldLogo ds x y w h = do+ Just doc <- liftIO $ currentDocument+ Just canvas <- liftIO $ getElementById doc ("cwlogo" :: JSString) case getColorDS ds of- Nothing -> js_canvasDrawImage ctx canvas x y w h+ Nothing -> CM.drawImage (canvasFromElement canvas) x y w h Just (RGBA r g b a) -- This is a tough case. The best we can do is to allocate an -- offscreen buffer as a temporary. -> do- buf <- Canvas.create w h- bufctx <- js_getCodeWorldContext buf- applyColor bufctx ds- Canvas.fillRect 0 0 (fromIntegral w) (fromIntegral h) bufctx- js_setGlobalCompositeOperation bufctx "destination-in"- js_canvasDrawImage bufctx canvas 0 0 w h- js_canvasDrawImage ctx (elementFromCanvas buf) x y w h+ (img, _) <- CM.newImage w h $ do+ applyColor ds+ CM.fillRect 0 0 (fromIntegral w) (fromIntegral h)+ CM.globalCompositeOperation "destination-in"+ CM.drawImage (canvasFromElement canvas) 0 0 w h+ CM.drawImage img x y w h -- Debug Mode logic inspectStatic :: Picture -> IO ()@@ -426,17 +476,14 @@ let canvas = unsafeCoerce c :: Element nodeId = pFromJSVal n drawing <- pictureToDrawing <$> getpicture- let node =- fromMaybe (Drawings []) $ fst <$> getDrawNode nodeId drawing+ let node = fromMaybe (Drawings []) $ fst <$> getDrawNode nodeId drawing offscreenCanvas <- Canvas.create 500 500 setCanvasSize canvas canvas setCanvasSize (elementFromCanvas offscreenCanvas) canvas screen <- js_getCodeWorldContext (canvasFromElement canvas) rect <- getBoundingClientRect canvas- buffer <-- setupScreenContext (elementFromCanvas offscreenCanvas) rect- drawFrame buffer (node <> coordinatePlaneDrawing)- Canvas.restore buffer+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame (node <> coordinatePlaneDrawing) rect <- getBoundingClientRect canvas cw <- ClientRect.getWidth rect ch <- ClientRect.getHeight rect@@ -558,7 +605,7 @@ ] obj retVal obj- ThickCircle cs r lw -> do+ ThickCircle cs lw r -> do obj <- init "thickCircle" setProps [ ("radius", pToJSVal r)@@ -641,16 +688,16 @@ ] obj retVal obj- Text cs txt -> do- obj <- init "text"+ Lettering cs txt -> do+ obj <- init "lettering" setProps [ ("font", pToJSVal $ fontString Plain Serif) , ("text", pToJSVal txt) ] obj retVal obj- StyledText cs style font txt -> do- obj <- init "styledText"+ StyledLettering cs style font txt -> do+ obj <- init "styledLettering" setProps [ ("font", pToJSVal $ fontString style font) , ("text", pToJSVal txt)@@ -683,6 +730,13 @@ [("picture", picJS), ("x", pToJSVal x), ("y", pToJSVal y)] obj retVal obj+ Dilate cs k p -> do+ obj <- init "scale"+ picJS <- picToObj' p+ setProps+ [("picture", picJS), ("k", pToJSVal k)]+ obj+ retVal obj Rotate cs angle p -> do obj <- init "rotate" picJS <- picToObj' p@@ -728,217 +782,251 @@ return $ (unsafeCoerce arr :: JSVal) setProps xs obj = liftIO $ void $ mapM (\(s, v) -> setProp s v obj) xs +trim :: Int -> String -> String+trim x y = let mid = (x - 2) `div` 2+ in case x >= (length y) of+ True -> y :: String+ False -> take mid y ++ ".." ++ (reverse $ take mid $ reverse y)++showShortFloat :: Double -> String+showShortFloat x = stripZeros (showFFloatAlt (Just 4) x "")+ where stripZeros = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse++describePicture :: Picture -> String+describePicture (Rectangle _ w h) = "rectangle { width = " ++ showShortFloat w ++ ", height = " ++ showShortFloat h ++ " }"+describePicture (SolidPolygon _ pts) = "solidPolygon { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }"+describePicture (SolidClosedCurve _ pts) = "solidClosedCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }"+describePicture (Polygon _ pts) = "polygon { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }"+describePicture (ThickPolygon _ pts w) = "thickPolygon { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }"+describePicture (SolidRectangle _ w h) = "solidRectangle { width = " ++ showShortFloat w ++ ", height = " ++ showShortFloat h ++ " }"+describePicture (ThickRectangle _ lw w h) = "thickRectangle { linewidth = " ++ showShortFloat lw ++ ", width = " ++ showShortFloat w ++ ", height = " ++ showShortFloat h ++ " }"+describePicture (ClosedCurve _ pts) = "closedCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }"+describePicture (ThickClosedCurve _ pts w) = "thickClosedCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }"+describePicture (Circle _ r) = "circle { radius = " ++ showShortFloat r ++ " }"+describePicture (SolidCircle _ r) = "solidCircle { radius = " ++ showShortFloat r ++ " }"+describePicture (ThickCircle _ lw r) = "thickCircle { linewidth = " ++ showShortFloat lw ++ ", radius = " ++ showShortFloat r ++ " }"+describePicture (Polyline _ pts) = "polyline { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }"+describePicture (ThickPolyline _ pts w) = "thickPolyline { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }"+describePicture (Curve _ pts) = "curve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ " }"+describePicture (ThickCurve _ pts w) = "thickCurve { points = " ++ intercalate ", " [ "(" ++ showShortFloat x ++ ", " ++ showShortFloat y ++ ")" | (x, y) <- pts ] ++ ", width = " ++ showShortFloat w ++ " }"+describePicture (Sector _ b e r) = "sector { startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ showShortFloat b ++ " radians)" ++ ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ showShortFloat e ++ " radias )," ++ " radius = " ++ showShortFloat r ++ " }"+describePicture (Arc _ b e r) = "arc { startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ showShortFloat b ++ " radians)" ++ ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ showShortFloat e ++ " radias )," ++ " radius = " ++ showShortFloat r ++ " }"+describePicture (ThickArc _ b e r w) = "thickArc { startAngle = " ++ showShortFloat (180 * b / pi) ++ "° (" ++ showShortFloat b ++ " radians)" ++ ", endAngle = " ++ showShortFloat (180 * e / pi) ++ "°" ++ " (" ++ showShortFloat e ++ " radias )," ++ " radius = " ++ showShortFloat r ++ ", width = " ++ showShortFloat w ++ " }"+describePicture (Lettering _ txt) = printf "lettering { text = '%s' }" txt+describePicture (Blank _) = "blank"+describePicture (StyledLettering _ style font txt) = printf " styledLettering { style = %s , font = %s, text = '%s' }" (show style) (show font) txt+describePicture (Color _ (RGBA r g b a) _) = "colored { color = RGBA(" ++ showShortFloat r ++ ", " ++ showShortFloat g ++ ", " ++ showShortFloat b ++ ", " ++ showShortFloat a ++ ") }"+describePicture (Translate _ x y _) = "translated { x = " ++ showShortFloat x ++ ", y = " ++ showShortFloat y ++ " }"+describePicture (Scale _ x y _) = "scaled { x = " ++ showShortFloat x ++ ", y = " ++ showShortFloat y ++ " }"+describePicture (Rotate _ angle _) = "rotated { angle = " ++ showShortFloat angle ++ "° }"+describePicture (Dilate _ k _) = "dilated { factor = " ++ showShortFloat k ++ " }"+describePicture (Logo _) = "codeWorldLogo"+describePicture (CoordinatePlane _) = "coordinatePlane"+describePicture (Pictures _) = "pictures"+ setCallInfo :: Picture -> Object -> IO ()-setCallInfo pic obj =- case findCSMain (getPictureCS pic) of- Just (callName, src) -> do- setProp "name" (pToJSVal $ callName) obj- setProp "startLine" (pToJSVal $ srcLocStartLine src) obj- setProp "startCol" (pToJSVal $ srcLocStartCol src) obj- setProp "endLine" (pToJSVal $ srcLocEndLine src) obj- setProp "endCol" (pToJSVal $ srcLocEndCol src) obj+setCallInfo pic obj = do+ case getPictureSrcLoc pic of+ Just loc -> do+ setProp "name" (pToJSVal $ (trim 80 . describePicture) pic) obj+ setProp "startLine" (pToJSVal $ srcLocStartLine loc) obj+ setProp "startCol" (pToJSVal $ srcLocStartCol loc) obj+ setProp "endLine" (pToJSVal $ srcLocEndLine loc) obj+ setProp "endCol" (pToJSVal $ srcLocEndCol loc) obj Nothing -> return () -findCSMain :: CallStack -> Maybe (String, SrcLoc)-findCSMain cs =- Data.List.find ((== "main") . srcLocPackage . snd) (getCallStack cs)--getPictureCS :: Picture -> CallStack-getPictureCS (SolidPolygon cs _) = cs-getPictureCS (SolidClosedCurve cs _) = cs-getPictureCS (Polygon cs _) = cs-getPictureCS (ThickPolygon cs _ _) = cs-getPictureCS (Rectangle cs _ _) = cs-getPictureCS (SolidRectangle cs _ _) = cs-getPictureCS (ThickRectangle cs _ _ _) = cs-getPictureCS (ClosedCurve cs _) = cs-getPictureCS (ThickClosedCurve cs _ _) = cs-getPictureCS (Circle cs _) = cs-getPictureCS (SolidCircle cs _) = cs-getPictureCS (ThickCircle cs _ _) = cs-getPictureCS (Polyline cs _) = cs-getPictureCS (ThickPolyline cs _ _) = cs-getPictureCS (Curve cs _) = cs-getPictureCS (ThickCurve cs _ _) = cs-getPictureCS (Sector cs _ _ _) = cs-getPictureCS (Arc cs _ _ _) = cs-getPictureCS (ThickArc cs _ _ _ _) = cs-getPictureCS (Text cs _) = cs-getPictureCS (Blank cs) = cs-getPictureCS (StyledText cs _ _ _) = cs-getPictureCS (Color cs _ _) = cs-getPictureCS (Translate cs _ _ _) = cs-getPictureCS (Scale cs _ _ _) = cs-getPictureCS (Rotate cs _ _) = cs-getPictureCS (Logo cs) = cs-getPictureCS (CoordinatePlane cs) = cs-getPictureCS (Pictures _) = emptyCallStack+getPictureSrcLoc :: Picture -> Maybe SrcLoc+getPictureSrcLoc (SolidPolygon loc _) = Just loc+getPictureSrcLoc (SolidClosedCurve loc _) = Just loc+getPictureSrcLoc (Polygon loc _) = Just loc+getPictureSrcLoc (ThickPolygon loc _ _) = Just loc+getPictureSrcLoc (Rectangle loc _ _) = Just loc+getPictureSrcLoc (SolidRectangle loc _ _) = Just loc+getPictureSrcLoc (ThickRectangle loc _ _ _) = Just loc+getPictureSrcLoc (ClosedCurve loc _) = Just loc+getPictureSrcLoc (ThickClosedCurve loc _ _) = Just loc+getPictureSrcLoc (Circle loc _) = Just loc+getPictureSrcLoc (SolidCircle loc _) = Just loc+getPictureSrcLoc (ThickCircle loc _ _) = Just loc+getPictureSrcLoc (Polyline loc _) = Just loc+getPictureSrcLoc (ThickPolyline loc _ _) = Just loc+getPictureSrcLoc (Curve loc _) = Just loc+getPictureSrcLoc (ThickCurve loc _ _) = Just loc+getPictureSrcLoc (Sector loc _ _ _) = Just loc+getPictureSrcLoc (Arc loc _ _ _) = Just loc+getPictureSrcLoc (ThickArc loc _ _ _ _) = Just loc+getPictureSrcLoc (Lettering loc _) = Just loc+getPictureSrcLoc (Blank loc) = Just loc+getPictureSrcLoc (StyledLettering loc _ _ _) = Just loc+getPictureSrcLoc (Color loc _ _) = Just loc+getPictureSrcLoc (Translate loc _ _ _) = Just loc+getPictureSrcLoc (Scale loc _ _ _) = Just loc+getPictureSrcLoc (Dilate loc _ _) = Just loc+getPictureSrcLoc (Rotate loc _ _) = Just loc+getPictureSrcLoc (Logo loc) = Just loc+getPictureSrcLoc (CoordinatePlane loc) = Just loc+getPictureSrcLoc (Pictures _) = Nothing -- If a picture is found, the result will include an array of the base picture -- and all transformations. findTopShapeFromPoint :: Point -> Drawing -> IO (Maybe NodeId) findTopShapeFromPoint (x, y) pic = do- offscreen <- Canvas.create 500 500- context <- Canvas.getContext offscreen- (found, node) <-- findTopShape- context- (translateDS (10 - x / 25) (y / 25 - 10) initialDS)- pic+ buf <- Canvas.create 500 500+ ctx <- Canvas.getContext buf+ (found, node) <- runCanvasM ctx $+ findTopShape (translateDS (10 - x / 25) (y / 25 - 10) initialDS)+ pic case found of True -> return $ Just node False -> return Nothing -findTopShape :: Canvas.Context -> DrawState -> Drawing -> IO (Bool, Int)-findTopShape ctx ds (Shape drawer) = do- contained <- shapeContains $ drawer ctx ds+findTopShape :: DrawState -> Drawing -> CanvasM (Bool, Int)+findTopShape ds (Shape drawer) = do+ contained <- shapeContains $ drawer ds case contained of True -> return (True, 0) False -> return (False, 1)-findTopShape ctx ds (Transformation f d) =- map2 (+ 1) $ findTopShape ctx (f ds) d-findTopShape ctx ds (Drawings []) = return (False, 1)-findTopShape ctx ds (Drawings (dr:drs)) = do- (found, count) <- findTopShape ctx ds dr+findTopShape ds (Transformation f d) =+ map2 (+ 1) $ findTopShape (f ds) d+findTopShape ds (Drawings []) = return (False, 1)+findTopShape ds (Drawings (dr:drs)) = do+ (found, count) <- findTopShape ds dr case found of True -> return (True, count + 1)- False -> map2 (+ count) $ findTopShape ctx ds (Drawings drs)+ False -> map2 (+ count) $ findTopShape ds (Drawings drs) map2 :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) map2 = fmap . fmap -isPointInPath :: Canvas.Context -> IO Bool-isPointInPath = js_isPointInPath 0 0--isPointInStroke :: Canvas.Context -> IO Bool-isPointInStroke = js_isPointInStroke 0 0---- Canvas.isPointInPath does not provide a way to get the return value--- https://github.com/ghcjs/ghcjs-base/blob/master/JavaScript/Web/Canvas.hs#L212-foreign import javascript unsafe "$3.isPointInPath($1,$2)"- js_isPointInPath :: Double -> Double -> Canvas.Context -> IO Bool--foreign import javascript unsafe "$3.isPointInStroke($1,$2)"- js_isPointInStroke :: Double -> Double -> Canvas.Context -> IO Bool- foreign import javascript unsafe "initDebugMode($1,$2,$3,$4,$5)"- js_initDebugMode ::- Callback (JSVal -> IO JSVal) ->- Callback (JSVal -> IO ()) ->- Callback (IO JSVal) ->- Callback (JSVal -> JSVal -> IO ()) ->- Callback (JSVal -> JSVal -> IO ()) -> IO ()+ js_initDebugMode :: Callback (JSVal -> IO JSVal)+ -> Callback (JSVal -> IO ())+ -> Callback (IO JSVal)+ -> Callback (JSVal -> JSVal -> IO ())+ -> Callback (JSVal -> JSVal -> IO ())+ -> IO () ----------------------------------------------------------------------------------- -- GHCJS Drawing-type Drawer = Canvas.Context -> DrawState -> DrawMethods+type Drawer = DrawState -> DrawMethods data DrawMethods = DrawMethods- { drawShape :: IO ()- , shapeContains :: IO Bool+ { drawShape :: CanvasM ()+ , shapeContains :: CanvasM Bool } -polygonDrawer ps smooth ctx ds =+polygonDrawer ps smooth ds = DrawMethods- { drawShape = trace >> applyColor ctx ds >> Canvas.fill ctx- , shapeContains = trace >> isPointInPath ctx+ { drawShape = do+ trace+ applyColor ds+ CM.fill+ , shapeContains = do+ trace+ CM.isPointInPath (0, 0) } where- trace = withDS ctx ds $ followPath ctx ps True smooth+ trace = withDS ds $ followPath ps True smooth -pathDrawer ps w closed smooth ctx ds =+pathDrawer ps w closed smooth ds = DrawMethods- { drawShape = drawFigure ctx ds w $ followPath ctx ps closed smooth+ { drawShape = drawFigure ds w $ followPath ps closed smooth , shapeContains = do let width = if w == 0 then 0.3 else w- drawFigure ctx ds width $ followPath ctx ps closed smooth- isPointInStroke ctx+ drawFigure ds width $ followPath ps closed smooth+ CM.isPointInStroke (0, 0) } -sectorDrawer b e r ctx ds =+sectorDrawer b e r ds = DrawMethods- { drawShape = trace >> applyColor ctx ds >> Canvas.fill ctx- , shapeContains = trace >> isPointInPath ctx+ { drawShape = do+ trace+ applyColor ds+ CM.fill+ , shapeContains = do+ trace+ CM.isPointInPath (0, 0) } where trace =- withDS ctx ds $ do- Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx- Canvas.lineTo 0 0 ctx+ withDS ds $ do+ CM.arc 0 0 (25 * abs r) b e (b > e)+ CM.lineTo (0, 0) -arcDrawer b e r w ctx ds =+arcDrawer b e r w ds = DrawMethods { drawShape =- drawFigure ctx ds w $ Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx+ drawFigure ds w $ CM.arc 0 0 (25 * abs r) b e (b > e) , shapeContains = do let width = if w == 0 then 0.3 else w- Canvas.lineWidth (width * 25) ctx- drawFigure ctx ds width $- Canvas.arc 0 0 (25 * abs r) b e (b > e) ctx- isPointInStroke ctx+ CM.lineWidth (width * 25)+ drawFigure ds width $+ CM.arc 0 0 (25 * abs r) b e (b > e)+ CM.isPointInStroke (0, 0) } -textDrawer sty fnt txt ctx ds =+textDrawer sty fnt txt ds = DrawMethods { drawShape =- withDS ctx ds $ do- Canvas.scale 1 (-1) ctx- applyColor ctx ds- Canvas.font (fontString sty fnt) ctx- Canvas.fillText (textToJSString txt) 0 0 ctx+ withDS ds $ do+ CM.scale 1 (-1)+ applyColor ds+ CM.font (fontString sty fnt)+ CM.fillText txt (0, 0) , shapeContains =- do Canvas.font (fontString sty fnt) ctx- width <- Canvas.measureText (textToJSString txt) ctx+ do CM.font (fontString sty fnt)+ width <- CM.measureText txt let height = 25 -- constant, defined in fontString- withDS ctx ds $- Canvas.rect ((-0.5) * width) ((-0.5) * height) width height ctx- isPointInPath ctx+ withDS ds $+ CM.rect ((-0.5) * width) ((-0.5) * height) width height+ CM.isPointInPath (0, 0) } -logoDrawer ctx ds =+logoDrawer ds = DrawMethods { drawShape =- withDS ctx ds $ do- Canvas.scale 1 (-1) ctx- drawCodeWorldLogo ctx ds (-225) (-50) 450 100+ withDS ds $ do+ CM.scale 1 (-1)+ drawCodeWorldLogo ds (-221) (-91) 442 182 , shapeContains =- do withDS ctx ds $ Canvas.rect (-225) (-50) 450 100 ctx- isPointInPath ctx+ withDS ds $ do+ CM.rect (-221) (-91) 442 182+ CM.isPointInPath (0, 0) } -coordinatePlaneDrawer ctx ds =+coordinatePlaneDrawer ds = DrawMethods- { drawShape = drawDrawing ctx ds coordinatePlaneDrawing- , shapeContains = fst <$> findTopShape ctx ds coordinatePlaneDrawing+ { drawShape = drawDrawing ds coordinatePlaneDrawing+ , shapeContains = fst <$> findTopShape ds coordinatePlaneDrawing } foreign import javascript unsafe "showCanvas()" js_showCanvas :: IO () -followPath :: Canvas.Context -> [Point] -> Bool -> Bool -> IO ()-followPath ctx [] closed _ = return ()-followPath ctx [p1] closed _ = return ()-followPath ctx ((sx, sy):ps) closed False = do- Canvas.moveTo (25 * sx) (25 * sy) ctx- forM_ ps $ \(x, y) -> Canvas.lineTo (25 * x) (25 * y) ctx- when closed $ Canvas.closePath ctx-followPath ctx [p1, p2] False True = followPath ctx [p1, p2] False False-followPath ctx ps False True = do+followPath :: [Point] -> Bool -> Bool -> CanvasM ()+followPath [] closed _ = return ()+followPath [p1] closed _ = return ()+followPath ((sx, sy):ps) closed False = do+ CM.moveTo (25 * sx, 25 * sy)+ forM_ ps $ \(x, y) -> CM.lineTo (25 * x, 25 * y)+ when closed $ CM.closePath+followPath [p1, p2] False True = followPath [p1, p2] False False+followPath ps False True = do let [(x1, y1), (x2, y2), (x3, y3)] = take 3 ps dprev = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) dnext = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) p = dprev / (dprev + dnext) cx = x2 + p * (x1 - x3) / 2 cy = y2 + p * (y1 - y3) / 2- Canvas.moveTo (25 * x1) (25 * y1) ctx- Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x2) (25 * y2) ctx- forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) ->+ CM.moveTo (25 * x1, 25 * y1)+ CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x2, 25 * y2)+ forM_ (zip4 ps (tail ps) (tail $ tail ps) (tail $ tail $ tail ps)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)@@ -948,25 +1036,21 @@ cy1 = y2 + r * (y3 - y1) / 2 cx2 = x3 + p * (x2 - x4) / 2 cy2 = y3 + p * (y2 - y4) / 2- in Canvas.bezierCurveTo- (25 * cx1)- (25 * cy1)- (25 * cx2)- (25 * cy2)- (25 * x3)- (25 * y3)- ctx+ CM.bezierCurveTo+ (25 * cx1, 25 * cy1)+ (25 * cx2, 25 * cy2)+ (25 * x3, 25 * y3) let [(x1, y1), (x2, y2), (x3, y3)] = reverse $ take 3 $ reverse ps dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) r = d1 / (dp + d1) cx = x2 + r * (x3 - x1) / 2 cy = y2 + r * (y3 - y1) / 2- Canvas.quadraticCurveTo (25 * cx) (25 * cy) (25 * x3) (25 * y3) ctx-followPath ctx ps@(_:(sx, sy):_) True True = do- Canvas.moveTo (25 * sx) (25 * sy) ctx+ CM.quadraticCurveTo (25 * cx, 25 * cy) (25 * x3, 25 * y3)+followPath ps@(_:(sx, sy):_) True True = do+ CM.moveTo (25 * sx, 25 * sy) let rep = cycle ps- forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) ->+ forM_ (zip4 ps (tail rep) (tail $ tail rep) (tail $ tail $ tail rep)) $ \((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> do let dp = sqrt ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) d1 = sqrt ((x3 - x2) ^ 2 + (y3 - y2) ^ 2) d2 = sqrt ((x4 - x3) ^ 2 + (y4 - y3) ^ 2)@@ -976,30 +1060,26 @@ cy1 = y2 + r * (y3 - y1) / 2 cx2 = x3 + p * (x2 - x4) / 2 cy2 = y3 + p * (y2 - y4) / 2- in Canvas.bezierCurveTo- (25 * cx1)- (25 * cy1)- (25 * cx2)- (25 * cy2)- (25 * x3)- (25 * y3)- ctx- Canvas.closePath ctx+ CM.bezierCurveTo+ (25 * cx1, 25 * cy1)+ (25 * cx2, 25 * cy2)+ (25 * x3, 25 * y3)+ CM.closePath -drawFigure :: Canvas.Context -> DrawState -> Double -> IO () -> IO ()-drawFigure ctx ds w figure = do- withDS ctx ds $ do+drawFigure :: DrawState -> Double -> CanvasM () -> CanvasM ()+drawFigure ds w figure = do+ withDS ds $ do figure when (w /= 0) $ do- Canvas.lineWidth (25 * w) ctx- applyColor ctx ds- Canvas.stroke ctx+ CM.lineWidth (25 * w)+ applyColor ds+ CM.stroke when (w == 0) $ do- Canvas.lineWidth 1 ctx- applyColor ctx ds- Canvas.stroke ctx+ CM.lineWidth 1+ applyColor ds+ CM.stroke -fontString :: TextStyle -> Font -> JSString+fontString :: TextStyle -> Font -> Text fontString style font = stylePrefix style <> "25px " <> fontName font where stylePrefix Plain = ""@@ -1011,31 +1091,31 @@ fontName Handwriting = "cursive" fontName Fancy = "fantasy" fontName (NamedFont txt) =- "\"" <> textToJSString (T.filter (/= '"') txt) <> "\""+ "\"" <> T.filter (/= '"') txt <> "\"" -drawDrawing :: Canvas.Context -> DrawState -> Drawing -> IO ()-drawDrawing ctx ds (Shape shape) = drawShape $ shape ctx ds-drawDrawing ctx ds (Transformation f d) = drawDrawing ctx (f ds) d-drawDrawing ctx ds (Drawings drs) = mapM_ (drawDrawing ctx ds) (reverse drs)+drawDrawing :: DrawState -> Drawing -> CanvasM ()+drawDrawing ds (Shape shape) = drawShape $ shape ds+drawDrawing ds (Transformation f d) = drawDrawing (f ds) d+drawDrawing ds (Drawings drs) = mapM_ (drawDrawing ds) (reverse drs) -drawFrame :: Canvas.Context -> Drawing -> IO ()-drawFrame ctx drawing = do- Canvas.fillStyle 255 255 255 1 ctx- Canvas.fillRect (-250) (-250) 500 500 ctx- drawDrawing ctx initialDS drawing+drawFrame :: Drawing -> CanvasM ()+drawFrame drawing = do+ CM.fillColor 255 255 255 1+ CM.fillRect (-250) (-250) 500 500+ drawDrawing initialDS drawing -setupScreenContext :: Element -> ClientRect.ClientRect -> IO Canvas.Context-setupScreenContext canvas rect = do+withScreen :: Element -> ClientRect.ClientRect -> CanvasM a -> IO a+withScreen canvas rect action = do cw <- ClientRect.getWidth rect ch <- ClientRect.getHeight rect ctx <- js_getCodeWorldContext (canvasFromElement canvas)- Canvas.save ctx- Canvas.translate (realToFrac cw / 2) (realToFrac ch / 2) ctx- Canvas.scale (realToFrac cw / 500) (-realToFrac ch / 500) ctx- Canvas.lineWidth 0 ctx- Canvas.textAlign Canvas.Center ctx- Canvas.textBaseline Canvas.Middle ctx- return ctx+ runCanvasM ctx $ CM.saveRestore $ do+ CM.translate (realToFrac cw / 2) (realToFrac ch / 2)+ CM.scale (realToFrac cw / 500) (-realToFrac ch / 500)+ CM.lineWidth 0+ CM.textCenter+ CM.textMiddle+ action setCanvasSize :: Element -> Element -> IO () setCanvasSize target canvas = do@@ -1335,6 +1415,11 @@ , tokenStep :: StaticKey , tokenEvent :: StaticKey , tokenDraw :: StaticKey }+ | SteplessToken { tokenDeployHash :: Text+ , tokenNumPlayers :: Int+ , tokenInitial :: StaticKey+ , tokenEvent :: StaticKey+ , tokenDraw :: StaticKey } | PartialToken { tokenDeployHash :: Text } | NoToken deriving (Generic)@@ -1636,6 +1721,7 @@ -> (Int -> s -> Picture) -> IO () runGame token numPlayers initial stepHandler eventHandler drawHandler = do+ let fullStepHandler dt = stepHandler dt . eventHandler (-1) (TimePassing dt) js_showCanvas Just window <- currentWindow Just doc <- currentDocument@@ -1651,21 +1737,19 @@ gameHandle numPlayers initial- stepHandler+ fullStepHandler eventHandler token currentGameState screen <- js_getCodeWorldContext (canvasFromElement canvas) let go t0 lastFrame = do gs <- readMVar currentGameState- let pic = gameDraw stepHandler drawHandler gs t0+ let pic = gameDraw fullStepHandler drawHandler gs t0 picFrame <- makeStableName $! pic when (picFrame /= lastFrame) $ do rect <- getBoundingClientRect canvas- buffer <-- setupScreenContext (elementFromCanvas offscreenCanvas) rect- drawFrame buffer (pictureToDrawing pic)- Canvas.restore buffer+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame (pictureToDrawing pic) rect <- getBoundingClientRect canvas cw <- ClientRect.getWidth rect ch <- ClientRect.getHeight rect@@ -1677,7 +1761,7 @@ (round cw) (round ch) t1 <- nextFrame- modifyMVar_ currentGameState $ return . gameStep stepHandler t1+ modifyMVar_ currentGameState $ return . gameStep fullStepHandler t1 go t1 picFrame t0 <- getTime nullFrame <- makeStableName undefined@@ -1688,8 +1772,10 @@ -> (Double -> s -> s) -> (e -> s -> s) -> (s -> Drawing)+ -> (Double -> e) -> IO (e -> IO (), IO s)-run initial stepHandler eventHandler drawHandler = do+run initial stepHandler eventHandler drawHandler injectTime = do+ let fullStepHandler dt = stepHandler dt . eventHandler (injectTime dt) js_showCanvas Just window <- currentWindow Just doc <- currentDocument@@ -1713,10 +1799,8 @@ picFrame <- makeStableName $! pic when (picFrame /= lastFrame) $ do rect <- getBoundingClientRect canvas- buffer <-- setupScreenContext (elementFromCanvas offscreenCanvas) rect- drawFrame buffer pic- Canvas.restore buffer+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame pic rect <- getBoundingClientRect canvas cw <- ClientRect.getWidth rect ch <- ClientRect.getHeight rect@@ -1731,7 +1815,7 @@ if | needsTime -> do t1 <- nextFrame let dt = min (t1 - t0) 0.25- modifyMVar_ currentState (return . stepHandler dt)+ modifyMVar_ currentState (return . fullStepHandler dt) return t1 | otherwise -> do takeMVar eventHappened@@ -1742,7 +1826,7 @@ if | nextStateName /= lastStateName -> return True | not needsTime -> return False | otherwise ->- not <$> isUniversallyConstant stepHandler nextState+ not <$> isUniversallyConstant fullStepHandler nextState go t1 picFrame nextStateName nextNeedsTime t0 <- getTime nullFrame <- makeStableName undefined@@ -1803,10 +1887,8 @@ drawToScreen = withoutPreemption $ do drawing <- draw rect <- getBoundingClientRect canvas- buffer <-- setupScreenContext (elementFromCanvas offscreenCanvas) rect- drawFrame buffer drawing- Canvas.restore buffer+ withScreen (elementFromCanvas offscreenCanvas) rect $+ drawFrame drawing rect <- getBoundingClientRect canvas cw <- ClientRect.getWidth rect ch <- ClientRect.getHeight rect@@ -1860,6 +1942,7 @@ stepHandlerWrapper eventHandlerWrapper drawHandlerWrapper+ (Right . TimePassing) let pauseEvent True = sendEvent $ Left DebugStart pauseEvent False = sendEvent $ Left DebugStop highlightSelectEvent True n = sendEvent $ Left (HighlightEvent n)@@ -1905,6 +1988,7 @@ stepHandlerWrapper eventHandlerWrapper drawHandlerWrapper+ (Right . TimePassing) let pauseEvent True = sendEvent $ Left DebugStart pauseEvent False = sendEvent $ Left DebugStop highlightSelectEvent True n = sendEvent $ Left (HighlightEvent n)@@ -2019,6 +2103,7 @@ run :: s -> (Double -> s -> s) -> (Event -> s -> s) -> (s -> Picture) -> IO () run initial stepHandler eventHandler drawHandler = runBlankCanvas $ \context -> do+ let fullStepHandler dt = stepHandler dt . eventHandler (TimePassing dt) let rect = (Canvas.width context, Canvas.height context) offscreenCanvas <- Canvas.send context $ Canvas.newCanvas rect currentState <- newMVar initial@@ -2047,7 +2132,7 @@ round ((tn `diffUTCTime` t0) * 1000000)) t1 <- getCurrentTime let dt = realToFrac (t1 `diffUTCTime` t0)- modifyMVar_ currentState (return . stepHandler dt)+ modifyMVar_ currentState (return . fullStepHandler dt) return t1 | otherwise -> do takeMVar eventHappened@@ -2056,7 +2141,7 @@ nextStateName <- makeStableName $! nextState nextNeedsTime <- if nextStateName == lastStateName- then not <$> isUniversallyConstant stepHandler nextState+ then not <$> isUniversallyConstant fullStepHandler nextState else return True go t1 picFrame nextStateName nextNeedsTime t0 <- getCurrentTime@@ -2093,8 +2178,31 @@ -> IO () runGame = error "game API unimplemented in stand-alone interface mode" #endif+ -------------------------------------------------------------------------------- -- Common code for game interface++groupActivityOf numPlayers initial event draw = do+ dhash <- getDeployHash+ let token =+ SteplessToken+ { tokenDeployHash = dhash+ , tokenNumPlayers = numPlayers+ , tokenInitial = staticKey initial+ , tokenEvent = staticKey event+ , tokenDraw = staticKey draw+ }+ runGame+ token+ numPlayers+ (deRefStaticPtr initial)+ (const id)+ (deRefStaticPtr event)+ (deRefStaticPtr draw)++unsafeGroupActivityOf numPlayers initial event draw =+ unsafeCollaborationOf numPlayers initial (const id) event draw+ unsafeCollaborationOf numPlayers initial step event draw = do dhash <- getDeployHash let token = PartialToken dhash@@ -2122,12 +2230,14 @@ (deRefStaticPtr draw) ----------------------------------------------------------------------------------- Common code for interaction, animation and simulation interfaces+-- Common code for activity, interaction, animation and simulation interfaces+activityOf initial event draw = interactionOf initial (const id) event draw+ interactionOf initial step event draw = runInspect initial step event draw data Wrapped a = Wrapped { state :: a- , paused :: Bool+ , playbackSpeed :: Double , mouseMovedTime :: Double } deriving (Show) @@ -2138,14 +2248,15 @@ RestartButton :: Control Double BackButton :: Control Double TimeLabel :: Control Double+ SpeedSlider :: Control a wrappedStep :: (Double -> a -> a) -> Double -> Wrapped a -> Wrapped a wrappedStep f dt w = w { state =- if paused w+ if playbackSpeed w == 0 then state w- else f dt (state w)+ else f (dt * playbackSpeed w) (state w) , mouseMovedTime = mouseMovedTime w + dt } @@ -2165,14 +2276,16 @@ handleControl _ (x, y) RestartButton w | -9.4 < x && x < -8.6 && -9.4 < y && y < -8.6 = w {state = 0} handleControl _ (x, y) PlayButton w- | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {paused = False}+ | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {playbackSpeed = 1} handleControl _ (x, y) PauseButton w- | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {paused = True}+ | -8.4 < x && x < -7.6 && -9.4 < y && y < -8.6 = w {playbackSpeed = 0} handleControl _ (x, y) BackButton w | -7.4 < x && x < -6.6 && -9.4 < y && y < -8.6 = w {state = max 0 (state w - 0.1)} handleControl f (x, y) StepButton w | -6.4 < x && x < -5.6 && -9.4 < y && y < -8.6 = w {state = f 0.1 (state w)}+handleControl f (x, y) SpeedSlider w+ | -5.4 < x && x < -2.6 && -9.4 < y && y < -8.6 = w {playbackSpeed = 5 * (x + 5.4) / 2.8} handleControl _ _ _ w = w wrappedDraw ::@@ -2242,36 +2355,39 @@ (scaled 0.5 0.5 $ text (pack (showFFloatAlt (Just 4) (state w) "s"))) <> colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 3.0 0.8) <> colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 3.0 0.8)+drawControl w alpha SpeedSlider = translated (-4) (-9) p+ where+ p =+ + translated x 0 (solidRectangle 0.2 0.8) <>+ colored (RGBA 0.2 0.2 0.2 alpha) (rectangle 2.8 0.6) <>+ colored (RGBA 0.8 0.8 0.8 alpha) (solidRectangle 2.8 0.6)+ x = playbackSpeed w / 5 * 2.8 - 1.4 animationControls :: Wrapped Double -> [Control Double] animationControls w | mouseMovedTime w > 5 = []- | paused w && state w > 0 =- [RestartButton, PlayButton, StepButton, BackButton, TimeLabel]- | paused w = [RestartButton, PlayButton, StepButton, TimeLabel]- | otherwise = [RestartButton, PauseButton, TimeLabel]+ | playbackSpeed w == 0 && state w > 0 =+ [RestartButton, PlayButton, StepButton, BackButton, TimeLabel, SpeedSlider]+ | playbackSpeed w == 0 = [RestartButton, PlayButton, StepButton, TimeLabel, SpeedSlider]+ | otherwise = [RestartButton, PauseButton, TimeLabel, SpeedSlider] animationOf f = runPauseable initial (+) animationControls f where- initial = Wrapped {state = 0, paused = False, mouseMovedTime = 1000}+ initial = Wrapped {state = 0, playbackSpeed = 1, mouseMovedTime = 1000} simulationControls :: Wrapped w -> [Control w] simulationControls w | mouseMovedTime w > 5 = []- | paused w = [PlayButton, StepButton]- | otherwise = [PauseButton]+ | playbackSpeed w == 0 = [PlayButton, StepButton, SpeedSlider]+ | otherwise = [PauseButton, SpeedSlider] simulationOf simInitial simStep simDraw = runPauseable initial simStep simulationControls simDraw where initial =- Wrapped {state = simInitial, paused = False, mouseMovedTime = 1000}+ Wrapped {state = simInitial, playbackSpeed = 1, mouseMovedTime = 1000} trace msg x = unsafePerformIO $ do hPutStrLn stderr (T.unpack msg) return x--#ifdef ghcjs_HOST_OS----- GHCJS implementation of tracing and error handling-#endif
src/CodeWorld/Event.hs view
@@ -23,7 +23,7 @@ {-| An event initiated by the user. Values of this type represent events that the user triggers when- using an interaction, defined with 'interactionOf'.+ using an interactive program. Key events describe the key as 'Text'. Most keys are represented by a single character text string, with the capital letter or other@@ -63,6 +63,7 @@ | MouseRelease !MouseButton !Point | MouseMovement !Point+ | TimePassing !Double deriving (Eq, Show, Read) data MouseButton@@ -72,13 +73,19 @@ deriving (Eq, Show, Read) pattern PointerPress :: Point -> Event- pattern PointerPress p = MousePress LeftButton p pattern PointerRelease :: Point -> Event- pattern PointerRelease p = MouseRelease LeftButton p pattern PointerMovement :: Point -> Event- pattern PointerMovement p = MouseMovement p++{-# WARNING MousePress ["Please use PointerPress instead of MousePress.",+ "MousePress may be removed July 2019." ] #-}+{-# WARNING MouseRelease ["Please use PointerRelease instead of MouseRelease.",+ "MouseRelease may be removed July 2019."] #-}+{-# WARNING MouseMovement ["Please use PointerMovement instead of MouseMovement.",+ "MouseMovement may be removed July 2019."] #-}+{-# WARNING MouseButton ["Please use pointer events, which don't have buttons.",+ "MouseButton may be removed July 2019."] #-}
src/CodeWorld/Picture.hs view
@@ -18,12 +18,25 @@ module CodeWorld.Picture where import CodeWorld.Color+import Data.List import Data.Monoid ((<>)) import Data.Text (Text, pack) import GHC.Stack type Point = (Double, Double) +translatedPoint :: Double -> Double -> Point -> Point+translatedPoint tx ty (x, y) = (x + tx, y + ty)++rotatedPoint :: Double -> Point -> Point+rotatedPoint = rotatedVector++scaledPoint :: Double -> Double -> Point -> Point+scaledPoint kx ky (x, y) = (kx * x, ky * y)++dilatedPoint :: Double -> Point -> Point+dilatedPoint k (x, y) = (k * x, k * y)+ type Vector = (Double, Double) vectorLength :: Vector -> Double@@ -49,90 +62,101 @@ dotProduct :: Vector -> Vector -> Double dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 +getDebugSrcLoc :: CallStack -> SrcLoc+getDebugSrcLoc cs =+ case Data.List.find ((== "main") . srcLocPackage) locs of+ Just loc -> loc+ Nothing -> error "Cannot find debug source location."+ where+ locs = map snd (getCallStack cs)+ data Picture- = SolidPolygon CallStack+ = SolidPolygon SrcLoc [Point]- | SolidClosedCurve CallStack+ | SolidClosedCurve SrcLoc [Point]- | Polygon CallStack+ | Polygon SrcLoc [Point]- | ThickPolygon CallStack+ | ThickPolygon SrcLoc [Point] !Double- | Rectangle CallStack+ | Rectangle SrcLoc !Double !Double- | SolidRectangle CallStack+ | SolidRectangle SrcLoc !Double !Double- | ThickRectangle CallStack+ | ThickRectangle SrcLoc !Double !Double !Double- | ClosedCurve CallStack+ | ClosedCurve SrcLoc [Point]- | ThickClosedCurve CallStack+ | ThickClosedCurve SrcLoc [Point] !Double- | Polyline CallStack+ | Polyline SrcLoc [Point]- | ThickPolyline CallStack+ | ThickPolyline SrcLoc [Point] !Double- | Curve CallStack+ | Curve SrcLoc [Point]- | ThickCurve CallStack+ | ThickCurve SrcLoc [Point] !Double- | Circle CallStack+ | Circle SrcLoc !Double- | SolidCircle CallStack+ | SolidCircle SrcLoc !Double- | ThickCircle CallStack+ | ThickCircle SrcLoc !Double !Double- | Sector CallStack+ | Sector SrcLoc !Double !Double !Double- | Arc CallStack+ | Arc SrcLoc !Double !Double !Double- | ThickArc CallStack+ | ThickArc SrcLoc !Double !Double !Double !Double- | StyledText CallStack+ | StyledLettering SrcLoc !TextStyle !Font !Text- | Text CallStack+ | Lettering SrcLoc !Text- | Color CallStack+ | Color SrcLoc !Color !Picture- | Translate CallStack+ | Translate SrcLoc !Double !Double !Picture- | Scale CallStack+ | Scale SrcLoc !Double !Double !Picture- | Rotate CallStack+ | Dilate SrcLoc !Double !Picture- | CoordinatePlane CallStack- | Logo CallStack+ | Rotate SrcLoc+ !Double+ !Picture+ | CoordinatePlane SrcLoc+ | Logo SrcLoc | Pictures [Picture]- | Blank CallStack+ | Blank SrcLoc data TextStyle = Plain | Bold- | Italic+ | Italic deriving (Show) data Font = SansSerif@@ -140,140 +164,134 @@ | Monospace | Handwriting | Fancy- | NamedFont !Text+ | NamedFont !Text deriving (Show) -- | A blank picture blank :: HasCallStack => Picture-blank = Blank callStack+blank = Blank (getDebugSrcLoc callStack) -- | A thin sequence of line segments, with these points as endpoints polyline :: HasCallStack => [Point] -> Picture-polyline ps = Polyline callStack ps+polyline ps = Polyline (getDebugSrcLoc callStack) ps -- | A thin sequence of line segments, with these points as endpoints path :: HasCallStack => [Point] -> Picture-path ps = Polyline callStack ps+path ps = Polyline (getDebugSrcLoc callStack) ps -{-# WARNING path "Please use polyline instead of path." #-}+{-# WARNING path ["Please use polyline instead of path.",+ "path may be removed July 2019."] #-} -- | A thick sequence of line segments, with given line width and endpoints thickPolyline :: HasCallStack => Double -> [Point] -> Picture-thickPolyline n ps = ThickPolygon callStack ps n+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 callStack ps n+thickPath n ps = ThickPolyline (getDebugSrcLoc callStack) ps n -{-# WARNING thickPath "Please used thickPolyline instead of thickPath." #-}+{-# WARNING thickPath ["Please used thickPolyline instead of thickPath.",+ "thickPath may be removed July 2019."] #-} -- | A thin polygon with these points as vertices polygon :: HasCallStack => [Point] -> Picture-polygon ps = Polygon callStack ps+polygon ps = Polygon (getDebugSrcLoc callStack) ps -- | A thick polygon with this line width and these points as -- vertices thickPolygon :: HasCallStack => Double -> [Point] -> Picture-thickPolygon n ps = ThickPolygon callStack ps n+thickPolygon n ps = ThickPolygon (getDebugSrcLoc callStack) ps n -- | A solid polygon with these points as vertices solidPolygon :: HasCallStack => [Point] -> Picture-solidPolygon ps = SolidPolygon callStack ps+solidPolygon ps = SolidPolygon (getDebugSrcLoc callStack) ps -- | A smooth curve passing through these points. curve :: HasCallStack => [Point] -> Picture-curve ps = Curve callStack ps+curve ps = Curve (getDebugSrcLoc callStack) ps -- | A thick smooth curve with this line width, passing through these points. thickCurve :: HasCallStack => Double -> [Point] -> Picture-thickCurve n ps = ThickCurve callStack ps n+thickCurve n ps = ThickCurve (getDebugSrcLoc callStack) ps n -- | A smooth closed curve passing through these points. closedCurve :: HasCallStack => [Point] -> Picture-closedCurve ps = ClosedCurve callStack ps---- | A smooth closed curve passing through these points.-loop :: HasCallStack => [Point] -> Picture-loop ps = ClosedCurve callStack ps--{-# WARNING loop "Please use closedCurve instead of loop." #-}+closedCurve ps = ClosedCurve (getDebugSrcLoc callStack) ps -- | A thick smooth closed curve with this line width, passing through these points. thickClosedCurve :: HasCallStack => Double -> [Point] -> Picture-thickClosedCurve n ps = ThickClosedCurve callStack ps n---- | A thick smooth closed curve with this line width, passing through these points.-thickLoop :: HasCallStack => Double -> [Point] -> Picture-thickLoop n ps = ThickClosedCurve callStack ps n--{-# WARNING thickLoop "Please use thickClosedCurve instead of thickLoop." #-}+thickClosedCurve n ps = ThickClosedCurve (getDebugSrcLoc callStack) ps n -- | A solid smooth closed curve passing through these points. solidClosedCurve :: HasCallStack => [Point] -> Picture-solidClosedCurve ps = SolidClosedCurve callStack ps---- | A solid smooth closed curve passing through these points.-solidLoop :: HasCallStack => [Point] -> Picture-solidLoop ps = SolidClosedCurve callStack ps--{-# WARNING solidLoop "Please use solidClosedCurve instead of solidLoop." #-}+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) ] -- | A thin rectangle, with this width and height rectangle :: HasCallStack => Double -> Double -> Picture-rectangle w h = Rectangle callStack w h+rectangle w h = Rectangle (getDebugSrcLoc callStack) w h -- | A solid rectangle, with this width and height solidRectangle :: HasCallStack => Double -> Double -> Picture-solidRectangle w h = SolidRectangle callStack w h+solidRectangle w h = SolidRectangle (getDebugSrcLoc callStack) w h -- | A thick rectangle, with this line width, and width and height thickRectangle :: HasCallStack => Double -> Double -> Double -> Picture-thickRectangle lw w h = ThickRectangle callStack lw w h+thickRectangle lw w h = ThickRectangle (getDebugSrcLoc callStack) lw w h -- | A thin circle, with this radius circle :: HasCallStack => Double -> Picture-circle = Circle callStack +circle = Circle (getDebugSrcLoc callStack) -- | A thick circle, with this line width and radius thickCircle :: HasCallStack => Double -> Double -> Picture-thickCircle = ThickCircle callStack+thickCircle = ThickCircle (getDebugSrcLoc callStack) -- | A thin arc, starting and ending at these angles, with this radius -- -- Angles are in radians. arc :: HasCallStack => Double -> Double -> Double -> Picture-arc b e r = Arc callStack b e r+arc b e r = Arc (getDebugSrcLoc callStack) b e r -- | A thick arc with this line width, starting and ending at these angles, -- with this radius. -- -- Angles are in radians. thickArc :: HasCallStack => Double -> Double -> Double -> Double -> Picture-thickArc w b e r = ThickArc callStack b e r w+thickArc w b e r = ThickArc (getDebugSrcLoc callStack) b e r w -- | A solid circle, with this radius solidCircle :: HasCallStack => Double -> Picture-solidCircle = SolidCircle callStack +solidCircle = SolidCircle (getDebugSrcLoc callStack) -- | A solid sector of a circle (i.e., a pie slice) starting and ending at these -- angles, with this radius -- -- Angles are in radians. sector :: HasCallStack => Double -> Double -> Double -> Picture-sector = Sector callStack+sector = Sector (getDebugSrcLoc callStack) --- | A piece of text+-- | A rendering of text characters. text :: HasCallStack => Text -> Picture-text = Text callStack+text = Lettering (getDebugSrcLoc callStack) +-- | 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 = StyledText callStack+styledText = StyledLettering (getDebugSrcLoc callStack) +-- | A rendering of text characters onto a Picture, with a specific+-- choice of font and style.+styledLettering :: HasCallStack => TextStyle -> Font -> Text -> Picture+styledLettering = StyledLettering (getDebugSrcLoc callStack)+ -- | A picture drawn entirely in this color. colored :: HasCallStack => Color -> Picture -> Picture-colored = Color callStack+colored = Color (getDebugSrcLoc callStack) -- | A picture drawn entirely in this colour. coloured :: HasCallStack => Color -> Picture -> Picture@@ -281,21 +299,21 @@ -- | A picture drawn translated in these directions. translated :: HasCallStack => Double -> Double -> Picture -> Picture-translated = Translate callStack+translated = Translate (getDebugSrcLoc callStack) -- | A picture scaled by these factors. scaled :: HasCallStack => Double -> Double -> Picture -> Picture-scaled = Scale callStack+scaled = Scale (getDebugSrcLoc callStack) -- | A picture scaled by these factors. dilated :: HasCallStack => Double -> Picture -> Picture-dilated k = scaled k k+dilated = Dilate (getDebugSrcLoc callStack) -- | A picture rotated by this angle. -- -- Angles are in radians. rotated :: HasCallStack => Double -> Picture -> Picture-rotated = Rotate callStack+rotated = Rotate (getDebugSrcLoc callStack) -- A picture made by drawing these pictures, ordered from top to bottom. pictures :: [Picture] -> Picture@@ -329,8 +347,8 @@ -- main = drawingOf (myPicture <> coordinatePlane) -- myPicture = ... coordinatePlane :: HasCallStack => Picture-coordinatePlane = CoordinatePlane callStack+coordinatePlane = CoordinatePlane (getDebugSrcLoc callStack) -- | The CodeWorld logo. codeWorldLogo :: HasCallStack => Picture-codeWorldLogo = Logo callStack+codeWorldLogo = Logo (getDebugSrcLoc callStack)