codeworld-api 0.4.0 → 0.5.0

raw patch · 9 files changed

+858/−175 lines, 9 filesdep +witherabledep ~blank-canvasdep ~reflexdep ~timePVP ok

version bump matches the API change (PVP)

Dependencies added: witherable

Dependency ranges changed: blank-canvas, reflex, time

API changes (from Hackage documentation)

Files

• codeworld-api.cabal +12/−6
• src/CodeWorld.hs +3/−0
• src/CodeWorld/CanvasM.hs +3/−0
• src/CodeWorld/DrawState.hs +11/−0
• src/CodeWorld/Driver.hs +248/−143
• src/CodeWorld/Image.hs +19/−0
• src/CodeWorld/Parameter.hs +420/−0
• src/CodeWorld/Picture.hs +106/−26
• src/CodeWorld/Reflex.hs +36/−0

@@ -1,5 +1,5 @@ Name:                codeworld-api-Version:             0.4.0+Version:             0.5.0 Synopsis:            Graphics library for CodeWorld License:             Apache License-file:        LICENSE@@ -33,6 +33,8 @@   Exposed-modules:     CodeWorld,                        CodeWorld.App,                        CodeWorld.App2,+                       CodeWorld.Image,+                       CodeWorld.Parameter,                        CodeWorld.Reflex,                        CodeWorld.Sketches   Other-modules:       CodeWorld.CanvasM,@@ -59,9 +61,11 @@                        mtl                  >= 2.2.1 && < 2.3,                        random               >= 1.1   && < 1.2,                        ref-tf               >= 0.4   && < 0.5,-                       reflex               >= 0.6.2.3   && < 0.7,+                       reflex               >= 0.6.3 && < 0.7,                        template-haskell     >= 2.8   && < 2.15,-                       text                 >= 1.2.2 && < 1.3+                       text                 >= 1.2.2 && < 1.3,+                       time                 >= 1.8   && < 2.0,+                       witherable           >= 0.3   && < 0.4    if impl(ghcjs)     Js-sources:        jsbits/sim_fp.js@@ -116,9 +120,11 @@                        mtl                  >= 2.2.1 && < 2.3,                        random               >= 1.1   && < 1.2,                        ref-tf               >= 0.4   && < 0.5,-                       reflex               >= 0.6   && < 0.7,+                       reflex               >= 0.6.3 && < 0.7,                        template-haskell     >= 2.8   && < 2.15,-                       text                 >= 1.2.2 && < 1.3+                       text                 >= 1.2.2 && < 1.3,+                       time                 >= 1.8   && < 2.0,+                       witherable           >= 0.3   && < 0.4    if impl(ghcjs)     Js-sources:        jsbits/sim_fp.js@@ -129,7 +135,7 @@                        ghcjs-dom             >= 0.8 && < 0.9,                        transformers   else-    Build-depends:     blank-canvas          >= 0.6 && < 0.7,+    Build-depends:     blank-canvas          >= 0.6 && < 0.8,                        time                  >= 1.6.0 && < 1.9    Ghc-options:         -O2

@@ -66,6 +66,8 @@     scaled,     dilated,     rotated,+    reflected,+    clipped,     pictures,     (<>),     (&),@@ -74,6 +76,7 @@     Point,     translatedPoint,     rotatedPoint,+    reflectedPoint,     scaledPoint,     dilatedPoint,     Vector,

@@ -76,6 +76,7 @@            (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 ()@@ -192,6 +193,7 @@         CanvasM (const (Canvas.bezierCurveTo x1 y1 x2 y2 x3 y3))     arc x y r a1 a2 dir = CanvasM (const (Canvas.arc x y r a1 a2 dir))     rect x y w h = CanvasM (const (Canvas.rect x y w h))+    clip = CanvasM (const Canvas.clip)     fill = CanvasM (const Canvas.fill)     stroke = CanvasM (const Canvas.stroke)     fillRect x y w h = CanvasM (const (Canvas.fillRect x y w h))@@ -301,6 +303,7 @@     arc x y r a1 a2 dir = liftCanvas $         Canvas.arc (x, y, r, a1, a2, dir)     rect x y w h = liftCanvas $ Canvas.rect (x, y, w, h)+    clip = liftCanvas $ Canvas.clip ()     fill = liftCanvas $ Canvas.fill ()     stroke = liftCanvas $ Canvas.stroke ()     fillRect x y w h = liftCanvas $ Canvas.fillRect (x, y, w, h)

@@ -73,6 +73,17 @@     e     f +reflectDS :: Double -> DrawState -> DrawState+reflectDS th = mapDSAT $ \(AffineTransformation a b c d e f) ->+  AffineTransformation+    (a * cos r + c * sin r)+    (b * cos r + d * sin r)+    (a * sin r - c * cos r)+    (b * sin r - d * cos r)+    e+    f+  where r = 2 * th+ setColorDS :: Color -> DrawState -> DrawState setColorDS col = mapDSColor $ \mcol ->   case (col, mcol) of

@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wno-name-shadowing -Wno-orphans -Wno-unticked-promoted-constructors #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}@@ -10,7 +9,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE JavaScriptFFI #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-}@@ -53,6 +51,7 @@ import Data.Bool import Data.Char (chr) import Data.Dependent.Sum+import Data.Foldable import Data.IORef import Data.List (zip4, intercalate) import Data.Maybe@@ -60,6 +59,7 @@ import Data.Serialize.Text () import Data.Text (Text) import qualified Data.Text as T+import Data.Witherable import GHC.Fingerprint.Type import GHC.Generics import GHC.Stack@@ -156,15 +156,16 @@ viaOffscreen (RGBA r g b a) pic = do     w <- CM.getScreenWidth     h <- CM.getScreenHeight-    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)+    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 ()@@ -172,7 +173,7 @@ followPath ((sx, sy):ps) closed False = do     CM.moveTo (sx, sy)     forM_ ps $ \(x, y) -> CM.lineTo (x, y)-    when closed $ CM.closePath+    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@@ -243,7 +244,7 @@  fillFigure :: MonadCanvas m => DrawState -> m () -> m () fillFigure ds figure = do-    withDS ds $ figure+    withDS ds figure     applyColor ds     CM.fill @@ -281,6 +282,10 @@ drawPicture (Scale _ x y p) ds = drawPicture p (scaleDS x y ds) drawPicture (Dilate _ k p) ds = drawPicture p (scaleDS k k ds) 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 drawPicture (Pictures _ ps) ds = forM_ (reverse ps) $ \p -> drawPicture p ds drawPicture (PictureAnd _ ps) ds = forM_ (reverse ps) $ \p -> drawPicture p ds @@ -314,6 +319,10 @@ pictureContains (Scale _ x y p) ds pt = pictureContains p (scaleDS x y ds) pt pictureContains (Dilate _ k p) ds pt = pictureContains p (scaleDS k k ds) pt 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 pictureContains (Pictures _ ps) ds pt = orM [pictureContains p ds pt | p <- ps] pictureContains (PictureAnd _ ps) ds pt = orM [pictureContains p ds pt | p <- ps] @@ -328,6 +337,8 @@ isSimplePic (Scale _ _ _ p) = isSimplePic p isSimplePic (Dilate _ _ p) = isSimplePic p isSimplePic (Rotate _ _ p) = isSimplePic p+isSimplePic (Reflect _ _ p) = isSimplePic p+isSimplePic (Clip _ _ _ p) = isSimplePic p isSimplePic (Color _ c p) = not (isOpaque c) || isSimplePic p isSimplePic _ = True @@ -353,7 +364,7 @@     CM.isPointInStroke p  drawSector :: MonadCanvas m => Double -> Double -> Double -> DrawState -> m ()-drawSector b e r ds = do+drawSector b e r ds =     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@@ -362,7 +373,7 @@     CM.isPointInPath p  drawArc :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> m ()-drawArc b e r w ds = do+drawArc b e r w ds =     drawFigure ds w $ CM.arc 0 0 (abs r) b e (b > e)  arcContains :: MonadCanvas m => Double -> Double -> Double -> Double -> DrawState -> Point -> m Bool@@ -418,7 +429,7 @@         CM.fillRect (-w/2) (-h/2) w h         CM.globalCompositeOperation "destination-in"         withDS ds $ do-            CM.scale (1) (-1)+            CM.scale 1 (-1)             CM.drawImgURL name url imgw imgh  imageContains :: MonadCanvas m => Text -> Text -> Double -> Double -> DrawState -> Point -> m Bool@@ -495,18 +506,12 @@ getChildNodes (Scale _ _ _ p) = [p] getChildNodes (Dilate _ _ p) = [p] getChildNodes (Rotate _ _ p) = [p]+getChildNodes (Reflect _ _ p) = [p]+getChildNodes (Clip _ _ _ p) = [p] getChildNodes (Pictures _ ps) = ps getChildNodes (PictureAnd _ ps) = ps getChildNodes _ = [] -getRootTransform :: Picture -> DrawState -> DrawState-getRootTransform (Color _ c _) = setColorDS c-getRootTransform (Translate _ x y _) = translateDS x y-getRootTransform (Scale _ x y _) = scaleDS x y-getRootTransform (Dilate _ k _) = scaleDS k k-getRootTransform (Rotate _ r _) = rotateDS r-getRootTransform _ = id- findTopShape :: MonadCanvas m => DrawState -> Picture -> Double -> Double -> m (Maybe NodeId) findTopShape ds pic x y = do     (found, n) <- searchSingle ds pic x y@@ -514,20 +519,42 @@         then Just (NodeId n)         else Nothing   where-    searchSingle ds pic x y = case getChildNodes pic of-        [] -> do-            contained <- pictureContains pic ds (x, y)-            case contained of-                True -> return (True, 0)-                False -> return (False, 1)-        pics -> fmap (+ 1) <$> searchMulti (getRootTransform pic ds) pics x y+    searchSingle ds (Color _ _ 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+    searchSingle ds (Scale _ sx sy 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+    searchSingle ds (Rotate _ a 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+    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)+    searchSingle ds (Pictures _ ps) x y =+        fmap (+ 1) <$> searchMulti ds ps x y+    searchSingle ds (PictureAnd _ 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)+     searchMulti _ [] _ _ = return (False, 0)     searchMulti ds (pic:pics) x y = do         (found, count) <- searchSingle ds pic x y-        case found of-            True -> return (True, count)-            False -> fmap (+ count) <$> searchMulti ds pics 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)@@ -542,12 +569,12 @@ trim :: Int -> String -> String trim x y   | x >= length y = y-  | otherwise = take mid y ++ "..." ++ (reverse $ take mid $ reverse y)+  | otherwise = take mid y ++ "..." ++ reverse (take mid $ reverse y)   where mid = (x - 3) `div` 2 -showFloat :: Double -> String-showFloat x-  | haskellMode && x < 0 = "(" ++ result ++ ")"+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@@ -556,7 +583,7 @@ showPoints pts =     "[" ++     intercalate ", " [-        "(" ++ showFloat x ++ ", " ++ showFloat y ++ ")"+        "(" ++ showFloat False x ++ ", " ++ showFloat False y ++ ")"         | (x, y) <- pts     ] ++     "]"@@ -574,30 +601,34 @@   | c == pink = "pink"   | c == purple = "purple"   | c == gray = "gray"-  | haskellMode, a == 1 = printf "(RGB %s %s %s)" (showFloat r) (showFloat g) (showFloat b)-  | a == 1 = printf "RGB(%s, %s, %s)" (showFloat r) (showFloat g) (showFloat b)-  | haskellMode = printf "(RGBA %s %s %s %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a)-  | otherwise = printf "RGBA(%s, %s, %s, %s)" (showFloat r) (showFloat g) (showFloat b) (showFloat a)+  | 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)+  | haskellMode =+      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)  describePicture :: Picture -> String describePicture (Rectangle _ w h)-  | haskellMode = printf "rectangle %s %s" (showFloat w) (showFloat h)-  | otherwise   = printf "rectangle(%s, %s)" (showFloat w) (showFloat h)+  | haskellMode = printf "rectangle %s %s" (showFloat True w) (showFloat True h)+  | otherwise   = printf "rectangle(%s, %s)" (showFloat False w) (showFloat False h) describePicture (SolidRectangle _ w h)-  | haskellMode = printf "solidRectangle %s %s" (showFloat w) (showFloat h)-  | otherwise   = printf "solidRectangle(%s, %s)" (showFloat w) (showFloat h)+  | haskellMode = printf "solidRectangle %s %s" (showFloat True w) (showFloat True h)+  | otherwise   = printf "solidRectangle(%s, %s)" (showFloat False w) (showFloat False h) describePicture (ThickRectangle _ lw w h)-  | haskellMode = printf "thickRectangle %s %s %s" (showFloat lw) (showFloat w) (showFloat h)-  | otherwise   = printf "thickRectangle(%s, %s, %s)" (showFloat w) (showFloat h) (showFloat lw)+  | 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) describePicture (Circle _ r)-  | haskellMode = printf "circle %s" (showFloat r)-  | otherwise   = printf "circle(%s)" (showFloat r)+  | haskellMode = printf "circle %s" (showFloat True r)+  | otherwise   = printf "circle(%s)" (showFloat False r) describePicture (SolidCircle _ r)-  | haskellMode = printf "solidCircle %s" (showFloat r)-  | otherwise   = printf "solidCircle(%s)" (showFloat r)+  | haskellMode = printf "solidCircle %s" (showFloat True r)+  | otherwise   = printf "solidCircle(%s)" (showFloat False r) describePicture (ThickCircle _ lw r)-  | haskellMode = printf "thickCircle %s %s" (showFloat lw) (showFloat r)-  | otherwise   = printf "thickCircle(%s, %s)" (showFloat r) (showFloat lw)+  | haskellMode = printf "thickCircle %s %s" (showFloat True lw) (showFloat True r)+  | 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)@@ -608,35 +639,35 @@   | haskellMode = printf "polygon %s" (showPoints pts)   | otherwise   = printf "polygon(%s)" (showPoints pts) describePicture (ThickPolygon _ pts w)-  | haskellMode = printf "thickPolygon %s %s" (showFloat w) (showPoints pts)-  | otherwise   = printf "thickPolygon(%s, %s)" (showPoints pts) (showFloat w)+  | haskellMode = printf "thickPolygon %s %s" (showFloat True w) (showPoints pts)+  | 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) describePicture (ThickClosedCurve _ pts w)-  | haskellMode = printf "thickClosedCurve %s %s" (showFloat w) (showPoints pts)-  | otherwise   = printf "thickClosedCurve(%s, %s)" (showPoints pts) (showFloat w)+  | haskellMode = printf "thickClosedCurve %s %s" (showFloat True w) (showPoints pts)+  | 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) describePicture (ThickPolyline _ pts w)-  | haskellMode = printf "thickPolyline %s %s" (showFloat w) (showPoints pts)-  | otherwise   = printf "thickPolyline(%s, %s)" (showPoints pts) (showFloat w)+  | haskellMode = printf "thickPolyline %s %s" (showFloat True w) (showPoints pts)+  | 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) describePicture (ThickCurve _ pts w)-  | haskellMode = printf "thickCurve %s %s" (showFloat w) (showPoints pts)-  | otherwise   = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat w)+  | haskellMode = printf "thickCurve %s %s" (showFloat True w) (showPoints pts)+  | otherwise   = printf "thickCurve(%s, %s)" (showPoints pts) (showFloat False w) describePicture (Sector _ b e r)-  | haskellMode = printf "sector %s %s %s" (showFloat b) (showFloat e) (showFloat r)-  | otherwise   = printf "sector(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r)+  | 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) describePicture (Arc _ b e r)-  | haskellMode = printf "arc %s %s %s" (showFloat b) (showFloat e) (showFloat r)-  | otherwise   = printf "arc(%s°, %s°, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r)+  | 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) describePicture (ThickArc _ b e r w)-  | haskellMode = printf "thickArc %s %s %s %s" (showFloat w) (showFloat b) (showFloat e) (showFloat r)-  | otherwise   = printf "thickArc(%s°, %s°, %s, %s)" (showFloat (180 * b / pi)) (showFloat (180 * e / pi)) (showFloat r) (showFloat w)+  | 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) describePicture (Lettering _ txt)   | haskellMode = printf "lettering %s" (show txt)   | otherwise   = printf "lettering(%s)" (show txt)@@ -648,17 +679,23 @@   | haskellMode = printf "colored %s" (showColor c)   | otherwise   = printf "colored(..., %s)" (showColor c) describePicture (Translate _ x y _)-  | haskellMode = printf "translated %s %s" (showFloat x) (showFloat y)-  | otherwise   = printf "translated(..., %s, %s)" (showFloat x) (showFloat y)+  | haskellMode = printf "translated %s %s" (showFloat True x) (showFloat True y)+  | otherwise   = printf "translated(..., %s, %s)" (showFloat False x) (showFloat False y) describePicture (Scale _ x y _)-  | haskellMode = printf "scaled %s %s" (showFloat x) (showFloat y)-  | otherwise   = printf "scaled(..., %s, %s)" (showFloat x) (showFloat y)+  | haskellMode = printf "scaled %s %s" (showFloat True x) (showFloat True y)+  | otherwise   = printf "scaled(..., %s, %s)" (showFloat False x) (showFloat False y) describePicture (Rotate _ angle _)-  | haskellMode = printf "rotated %s" (showFloat angle)-  | otherwise   = printf "rotated(..., %s°)" (showFloat (180 * angle / pi))+  | haskellMode = printf "rotated %s" (showFloat True angle)+  | 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))+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) describePicture (Dilate _ k _)-  | haskellMode = printf "dilated %s" (showFloat k)-  | otherwise   = printf "dilated(..., %s)" (showFloat k)+  | haskellMode = printf "dilated %s" (showFloat True k)+  | otherwise   = printf "dilated(..., %s)" (showFloat False k) describePicture (Sketch _ name _ _ _) = T.unpack name describePicture (CoordinatePlane _) = "coordinatePlane" describePicture (Pictures _ _)@@ -696,6 +733,8 @@ getPictureSrcLoc (Scale loc _ _ _) = loc getPictureSrcLoc (Dilate loc _ _) = loc getPictureSrcLoc (Rotate loc _ _) = loc+getPictureSrcLoc (Reflect loc _ _) = loc+getPictureSrcLoc (Clip loc _ _ _) = loc getPictureSrcLoc (Sketch loc _ _ _ _) = loc getPictureSrcLoc (CoordinatePlane loc) = loc getPictureSrcLoc (Pictures loc _) = loc@@ -732,7 +771,7 @@         withScreen (elementFromCanvas offscreenCanvas) rect (drawFrame pic)         cw <- ClientRect.getWidth rect         ch <- ClientRect.getHeight rect-        when (cw > 0 && ch > 0) $+        when (cw > 0.5 && ch > 0.5) $             canvasDrawImage screen (elementFromCanvas offscreenCanvas)                             0 0 (round cw) (round ch) @@ -784,6 +823,8 @@         Scale _ _ _ p -> nodeWithChild pic p         Dilate _ _ p -> nodeWithChild pic p         Rotate _ _ p -> nodeWithChild pic p+        Reflect _ _ p -> nodeWithChild pic p+        Clip _ _ _ p -> nodeWithChild pic p         SolidPolygon _ _ -> leafNode pic         SolidClosedCurve _ _ -> leafNode pic         Polygon _ _ -> leafNode pic@@ -956,7 +997,7 @@  modifyMVarIfDifferent :: MVar s -> (s -> s) -> IO Bool modifyMVarIfDifferent var f =-    modifyMVar var $ \s0 -> do+    modifyMVar var $ \s0 ->         case ifDifferent f s0 of             Nothing -> return (s0, False)             Just s1 -> return (s1, True)@@ -1407,6 +1448,10 @@     = Dilate loc k <$> indexNode True (i + 1) n p indexNode True i n (Rotate loc r p)     = Rotate loc r <$> indexNode True (i + 1) n p+indexNode True i n (Reflect loc r p)+    = Reflect loc r <$> indexNode True (i + 1) n p+indexNode True i n (Clip loc x y p)+    = Clip loc x y <$> indexNode True (i + 1) n p indexNode keepTx i n p = go keepTx (i + 1) (getChildNodes p)   where go _ i [] = Left i         go keepTx i (pic:pics) =@@ -1705,9 +1750,12 @@ 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@@ -1726,16 +1774,14 @@     -> ReactiveInput t     -> m (R.Dynamic t Picture, R.Dynamic t Picture) runReactiveProgram (ReactiveProgram program) input = do-    ((), output) <- R.runDynamicWriterT (runReaderT program input)-    return $ R.splitDynPure $ do-        pics <- userPictures <$> output-        let userPicture = case pics of-                []  -> blank-                [p] -> p-                ps  -> pictures ps-        tform <- userTransform <$> output-        sysPic <- systemPicture <$> output-        return (userPicture, sysPic & tform userPicture)+    (_, 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@@ -1755,9 +1801,19 @@     ReactiveProgram . R.tellDyn . fmap (\a -> mempty { userTransform = a })  -- | Type class for the builder monad of a CodeWorld/Reflex app.-class (R.Reflex t, R.MonadHold t m, MonadFix m, R.PerformEvent t m,-       R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m)-  => ReflexCodeWorld t m | m -> t where+class+  (+    R.Reflex t,+    R.Adjustable t m,+    R.MonadHold t m,+    R.NotReady t m,+    R.PostBuild t m,+    R.PerformEvent t m,+    R.TriggerEvent t m,+    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) @@ -1783,9 +1839,19 @@     -- | Emits a given Dynamic picture to be drawn to the screen.     draw :: R.Dynamic t Picture -> m () -instance (R.Reflex t, R.MonadHold t m, MonadFix m, R.PerformEvent t m,-          R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m)-  => ReflexCodeWorld t (ReactiveProgram t m) where+instance+  (+    R.Reflex t,+    R.Adjustable t m,+    R.MonadHold t m,+    R.NotReady t m,+    R.PostBuild t m,+    R.PerformEvent t m,+    R.TriggerEvent t m,+    MonadFix m,+    MonadIO m,+    MonadIO (R.Performable m)+  ) => ReflexCodeWorld t (ReactiveProgram t m) where     getKeyPress = ReactiveProgram $ asks keyPress      getKeyRelease = ReactiveProgram $ asks keyRelease@@ -1802,13 +1868,36 @@      draw = ReactiveProgram . R.tellDyn . fmap (\a -> mempty { userPictures = [a] }) -splitDyn :: forall t a. R.Reflex t => R.Dynamic t (a -> Bool) -> R.Event t a -> (R.Event t a, R.Event t a)-splitDyn predicate e = R.fanEither $ R.attachPromptlyDynWith f predicate e-  where f pred val = if pred val then Right val else Left val- 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) +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 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++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 ()))+ #ifdef ghcjs_HOST_OS  createPhysicalReactiveInput@@ -1866,7 +1955,7 @@      pointerPosition <- R.holdDyn (0, 0) pointerMovement     pointerDown <- R.holdDyn False $-        R.mergeWith (&&) [True <$ pointerPress, False <$ pointerRelease]+        R.leftmost [True <$ pointerPress, False <$ pointerRelease]      return ReactiveInput{..} @@ -1898,9 +1987,18 @@             }  runReactive-    :: (forall t m. (R.Reflex t, R.MonadHold t m, MonadFix m, R.PerformEvent t m,-                     R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m)-        => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture)))+    :: (forall t m.+        ( R.Reflex t,+          R.Adjustable t m,+          R.MonadHold t m,+          R.NotReady t m,+          R.PostBuild t m,+          R.PerformEvent t m,+          R.TriggerEvent t m,+          MonadFix m,+          MonadIO m,+          MonadIO (R.Performable m)+        ) => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture)))     -> IO () runReactive program = do     showCanvas@@ -1929,12 +2027,16 @@         resizeEvent <- R.runSpiderHost $ R.newEventWithTrigger $ \trigger -> do             on window resize $ liftIO $ fireAndRedraw [trigger ==> ()]         logicalInput <- R.runSpiderHost $ inspectLogicalInput debugState physicalInput+        eventTriggers <- newChan         (inspectPicture, fireCommand) <- R.runSpiderHost $ R.hostPerformEventT $ do-            (inspectPicture, displayPicture) <- R.runPostBuildT (program logicalInput) postBuild+            (inspectPicture, displayPicture) <-+                flip R.runTriggerEventT eventTriggers .+                flip R.runPostBuildT postBuild $+                program logicalInput             let logicalPicture = drawDebugState <$> debugState                                                 <*> inspectPicture                                                 <*> displayPicture-            R.performEvent_ $ liftIO <$> R.mergeWith const [+            R.performEvent_ $ liftIO <$> R.leftmost [                 (setCanvasSize canvas canvas >>) . asyncRender <$>                     R.tagPromptlyDyn logicalPicture resizeEvent,                 asyncRender <$> R.updated logicalPicture,@@ -1945,29 +2047,31 @@         let fireAndRedraw events = R.runSpiderHost $ void $                 R.runFireCommand fireCommand events (return ()) -    let fireDebugUpdateAndRedraw f = R.runSpiderHost $ do-            state <- readRef debugUpdateTriggerRef-            case state of-                Just trigger -> void $-                    R.runFireCommand fireCommand [trigger ==> f] (return ())-                Nothing -> return ()-    let samplePicture = R.runSpiderHost $ R.runHostFrame $ R.sample $ R.current inspectPicture+    let+        fireDebugUpdateAndRedraw = sendEvent fireCommand debugUpdateTriggerRef+        samplePicture = R.runSpiderHost $ R.runHostFrame $ R.sample $ R.current inspectPicture     connectInspect canvas samplePicture fireDebugUpdateAndRedraw -    maybePostBuildTrigger <- readRef postBuildTriggerRef-    case maybePostBuildTrigger of-        Just trigger -> R.runSpiderHost $ void $-            R.runFireCommand fireCommand [trigger ==> ()] (return ())-        Nothing -> return ()+    sendEvent fireCommand postBuildTriggerRef () +    void $ asyncProcessEventTriggers eventTriggers fireCommand     waitForever  #else  runReactive-    :: (forall t m. (R.Reflex t, R.MonadHold t m, MonadFix m, R.PerformEvent t m,-                     R.Adjustable t m, MonadIO (R.Performable m), R.PostBuild t m)-        => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture)))+    :: (forall t m.+        ( R.Reflex t,+          R.Adjustable t m,+          R.MonadHold t m,+          R.NotReady t m,+          R.PostBuild t m,+          R.PerformEvent t m,+          R.TriggerEvent t m,+          MonadFix m,+          MonadIO m,+          MonadIO (R.Performable m)+        ) => (ReactiveInput t -> m (R.Dynamic t Picture, R.Dynamic t Picture)))     -> IO () runReactive program = runBlankCanvas $ \context -> do     let cw = Canvas.width context@@ -1993,31 +2097,29 @@      pointerPosition <- R.runSpiderHost $ R.holdDyn (0, 0) pointerMovement     pointerDown <- R.runSpiderHost $ R.holdDyn False $-        R.mergeWith (&&) [True <$ pointerPress, False <$ pointerRelease]+        R.leftmost [True <$ pointerPress, False <$ pointerRelease]      let input = ReactiveInput{..} +    triggeredEvents <- newChan     (_, fireCommand) <- R.runSpiderHost $ R.hostPerformEventT $ do-        (_inspectPicture, displayPicture) <- R.runPostBuildT (program input) postBuild-        R.performEvent_ $ liftIO <$> R.mergeWith const [+        (_inspectPicture, displayPicture) <-+            flip R.runTriggerEventT triggeredEvents .+            flip R.runPostBuildT postBuild $+            program input+        R.performEvent_ $ liftIO <$> R.leftmost [             frame <$> R.updated displayPicture,             frame <$> R.tagPromptlyDyn displayPicture postBuild             ]         return () -    let sendEvent :: forall a. IORef (Maybe (R.EventTrigger (R.SpiderTimeline R.Global) a)) -> a -> IO ()-        sendEvent triggerRef val = do-            mtrigger <- readRef triggerRef-            case mtrigger of-                Just trigger -> R.runSpiderHost $ void $-                    R.runFireCommand fireCommand [trigger ==> val] (return ())-                Nothing -> return ()+    let sendEvent'+            :: IORef (Maybe (R.EventTrigger (R.SpiderTimeline R.Global) a))+            -> a+            -> IO ()+        sendEvent' = sendEvent fireCommand -    maybePostBuildTrigger <- readRef postBuildTriggerRef-    case maybePostBuildTrigger of-        Just trigger -> R.runSpiderHost $ void $-            R.runFireCommand fireCommand [trigger ==> ()] (return ())-        Nothing -> return ()+    sendEvent' postBuildTriggerRef ()      t0 <- getCurrentTime     let go t1 = do@@ -2025,25 +2127,28 @@             forM_ events $ \event -> case Canvas.eType event of                 "keydown" | Just code <- Canvas.eWhich event -> do                     let keyName = keyCodeToText (fromIntegral code)-                    sendEvent keyPressTrigger keyName-                    when (T.length keyName == 1) $ sendEvent textEntryTrigger keyName+                    sendEvent' keyPressTrigger keyName+                    when (T.length keyName == 1) $ sendEvent' textEntryTrigger keyName                 "keyup" | Just code <- Canvas.eWhich event -> do                     let keyName = keyCodeToText (fromIntegral code)-                    sendEvent keyReleaseTrigger keyName+                    sendEvent' keyReleaseTrigger keyName                 "mousedown" | Just pos <- getMousePos (cw, ch) <$> Canvas.ePageXY event -> do-                    sendEvent pointerPressTrigger pos+                    sendEvent' pointerPressTrigger pos                 "mouseup" | Just pos <- getMousePos (cw, ch) <$> Canvas.ePageXY event -> do-                    sendEvent pointerReleaseTrigger pos+                    sendEvent' pointerReleaseTrigger pos                 "mousemove" | Just pos <- getMousePos (cw, ch) <$> Canvas.ePageXY event -> do-                    sendEvent pointerMovementTrigger pos+                    sendEvent' pointerMovementTrigger pos                 _ -> return ()              tn <- getCurrentTime             threadDelay $ max 0 (50000 - (round ((tn `diffUTCTime` t0) * 1000000)))             t2 <- getCurrentTime             let dt = realToFrac (t2 `diffUTCTime` t1)-            sendEvent timePassingTrigger dt+            sendEvent' timePassingTrigger dt             go t2-    go t0+    bracket+        (asyncProcessEventTriggers triggeredEvents fireCommand)+        killThread+        (const $ go t0)  #endif

@@ -0,0 +1,19 @@+{-+  Copyright 2019 The CodeWorld Authors. All rights reserved.++  Licensed under the Apache License, Version 2.0 (the "License");+  you may not use this file except in compliance with the License.+  You may obtain a copy of the License at++      http://www.apache.org/licenses/LICENSE-2.0++  Unless required by applicable law or agreed to in writing, software+  distributed under the License is distributed on an "AS IS" BASIS,+  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+  See the License for the specific language governing permissions and+  limitations under the License.+-}++module CodeWorld.Image (image) where++import CodeWorld.Picture

@@ -0,0 +1,420 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}++{-+  Copyright 2019 The CodeWorld Authors. All rights reserved.++  Licensed under the Apache License, Version 2.0 (the "License");+  you may not use this file except in compliance with the License.+  You may obtain a copy of the License at++      http://www.apache.org/licenses/LICENSE-2.0++  Unless required by applicable law or agreed to in writing, software+  distributed under the License is distributed on an "AS IS" BASIS,+  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+  See the License for the specific language governing permissions and+  limitations under the License.+-}++module CodeWorld.Parameter+  {-# WARNING "This is an experimental API.  It can change at any time." #-}+  ( Parameter,+    parametricDrawingOf,+    slider,+    toggle,+    counter,+    constant,+    random,+    timer,+    currentHour,+    currentMinute,+    currentSecond,+    converted,+    renamed,+  )+where++import CodeWorld+import CodeWorld.Driver (runInspect)+import Data.Function (on)+import Data.List (sortBy)+import Data.Text (Text, pack)+import qualified Data.Text as T+import Data.Time.Clock+import Data.Time.LocalTime+import Numeric (showFFloatAlt)+import System.IO.Unsafe (unsafePerformIO)+import System.Random (newStdGen, randomR)++-- | Bounds information for a parameter UI.  The fields are the+-- left and top coordinate, then the width and height.+type Bounds = (Double, Double, Double, Double)++-- | The source for a parameter that can be adjusted in a parametric+-- drawing.  Parameters can get their values from sliders, buttons,+-- counters, timers, etc.+data Parameter where+  Parameter ::+    Text ->+    Double ->+    Picture ->+    Bounds ->+    (Event -> Parameter) ->+    Parameter++-- | A drawing that depends on parameters.  The first argument is a+-- list of parameters.  The second is a picture, which depends on the+-- values of those parameters.  Each number used to retrieve the picture+-- is the value of the corresponding parameter in the first list.+parametricDrawingOf :: [Parameter] -> ([Double] -> Picture) -> IO ()+parametricDrawingOf initialParams mainPic =+  runInspect+    (zip [0 :: Int ..] (layoutParams 0 (-9.5) 9.5 initialParams), True, 5)+    (const id)+    change+    picture+    rawPicture+  where+    change (KeyPress " ") (params, vis, _) = (params, not vis, 2)+    change (PointerPress pt) (params, vis, t) =+      case (vis, pullMatch (hitTest pt . snd) params) of+        (True, (Just p, ps)) -> (fmap (changeParam (PointerPress pt)) p : ps, vis, t)+        _ -> (params, vis, t)+    change event (params, vis, t) =+      (map (fmap (changeParam event)) params, vis, changeTime event t)+    picture (params, vis, t) =+      showHideBanner t+        & (picWhen vis $ pictures (map (showParam . snd) params))+        & rawPicture (params, vis, t)+    rawPicture (params, _, _) =+      mainPic (map (getParam . snd) (sortBy (compare `on` fst) params))+    changeParam event (Parameter _ _ _ _ handle) = handle event+    showParam (Parameter _ _ pic _ _) = pic+    getParam (Parameter _ val _ _ _) = val+    changeTime (TimePassing dt) t = max 0 (t - dt)+    changeTime _ t = t+    showHideBanner t =+      picWhen (t > 0)+        $ translated 0 (-9)+        $ dilated 0.5+        $ colored (RGBA 0 0 0 t) (rectangle 18 2)+          & colored+            (RGBA 0 0 0 t)+            (lettering "Press Space to show/hide parameters.")+          & colored (RGBA 0.75 0.75 0.75 (min 0.8 t)) (solidRectangle 18 2)++-- | Wraps a list of parameters in frames to lay them out on the screen.+layoutParams :: Double -> Double -> Double -> [Parameter] -> [Parameter]+layoutParams _ _ _ [] = []+layoutParams maxw x y (p : ps)+  | y > (-9.5) + h + titleHeight =+    framedParam (x - left) (y - top - titleHeight) p+      : layoutParams (max maxw w) x (y - h - titleHeight - gap) ps+  | otherwise = layoutParams 0 (x + maxw + gap) 9.5 (p : ps)+  where+    Parameter _ _ _ (left, top, w, h) _ = p+    gap = 0.5++-- | Finds the first element of a list that matches the predicate, if any,+-- and removes it from the list, returning it separately from the remaining+-- elements.+pullMatch :: (a -> Bool) -> [a] -> (Maybe a, [a])+pullMatch _ [] = (Nothing, [])+pullMatch p (a : as)+  | p a = (Just a, as)+  | otherwise = fmap (a :) (pullMatch p as)++-- | Determines if a point is inside the screen area for a given parameter.+hitTest :: Point -> Parameter -> Bool+hitTest (x, y) (Parameter _ _ _ (left, top, w, h) _) =+  x > left && x < left + w && y < top && y > top - h++-- | Builds a parameter from an explicit state.+parameterOf ::+  Text ->+  state ->+  (Event -> state -> state) ->+  (state -> Double) ->+  (state -> Picture) ->+  (state -> Bounds) ->+  Parameter+parameterOf name initial change value picture bounds =+  Parameter+    name+    (value initial)+    (picture initial)+    (bounds initial)+    (\e -> parameterOf name (change e initial) change value picture bounds)++-- Puts a simple parameter in a draggable widget that let the user+-- manipulate it on the screen, and displays the name and value.+-- All parameters are enclosed in one of these automatically.+framedParam :: Double -> Double -> Parameter -> Parameter+framedParam ix iy iparam =+  parameterOf+    name+    (iparam, (ix, iy), True, Nothing)+    framedHandle+    (\(Parameter _ v _ _ _, _, _, _) -> v)+    framedPicture+    framedBounds+  where+    (Parameter name _ _ _ _) = iparam++-- | The state of a framedParam, which includes the original parameter,+-- its location, whether it's open (expanded) or not, and the anchor if+-- it is currently being dragged.+type FrameState = (Parameter, Point, Bool, Maybe Point)++framedHandle :: Event -> FrameState -> FrameState+framedHandle (PointerPress (px, py)) (param, (x, y), open, anchor)+  | onOpenButton = (param, (x, y), not open, anchor)+  | onTitleBar = (param, (x, y), open, Just (px, py))+  where+    Parameter _ _ _ (left, top, w, h) _ = param+    onTitleBar =+      abs (px - x - (left + w / 2)) < w / 2+        && abs (py - y - top - titleHeight / 2) < titleHeight / 2+    onOpenButton+      | w * h > 0 =+        abs (px - x - (left + w - titleHeight / 2)) < 0.2+          && abs (py - y - (top + titleHeight / 2)) < 0.2+      | otherwise = False+framedHandle (PointerRelease _) (param, loc, open, Just _) =+  (param, loc, open, Nothing)+framedHandle (PointerMovement (px, py)) (param, (x, y), open, Just (ax, ay)) =+  (param, (x + px - ax, y + py - ay), open, Just (px, py))+framedHandle (TimePassing dt) (Parameter _ _ _ _ handle, loc, open, anchor) =+  (handle (TimePassing dt), loc, open, anchor)+framedHandle event (Parameter _ _ _ _ handle, (x, y), True, anchor) =+  (handle (untranslated x y event), (x, y), True, anchor)+framedHandle _ other = other++framedPicture :: FrameState -> Picture+framedPicture (Parameter n v pic (left, top, w, h) _, (x, y), open, _) =+  translated x y $+    translated (left + w / 2) (top + titleHeight / 2) titleBar+      & translated (left + w / 2) (top - h / 2) clientArea+  where+    titleBar+      | w * h > 0 =+        rectangle w titleHeight+          & translated+            ((w - titleHeight) / 2)+            0+            (if open then collapseButton else expandButton)+          & translated+            (- titleHeight / 2)+            0+            ( clipped+                (w - titleHeight)+                titleHeight+                (dilated 0.5 (lettering titleText))+            )+          & colored titleColor (solidRectangle w titleHeight)+      | otherwise =+        rectangle w titleHeight+          & clipped w titleHeight (dilated 0.5 (lettering titleText))+          & colored titleColor (solidRectangle w titleHeight)+    titleText+      | T.length n > 10 = T.take 8 n <> "... = " <> formattedVal+      | otherwise = n <> " = " <> formattedVal+    formattedVal = pack (showFFloatAlt (Just 2) v "")+    collapseButton = rectangle 0.4 0.4 & solidPolygon [(-0.1, -0.1), (0.1, -0.1), (0, 0.1)]+    expandButton = rectangle 0.4 0.4 & solidPolygon [(-0.1, 0.1), (0.1, 0.1), (0, -0.1)]+    clientArea =+      picWhen (w * h > 0) $+        rectangle w h+          & clipped w h pic+          & colored bgColor (solidRectangle 5 1)++framedBounds :: FrameState -> Bounds+framedBounds (Parameter _ _ _ (left, top, w, h) _, (x, y), True, _) =+  (x + left, y + top + titleHeight, w, h + titleHeight)+framedBounds (Parameter _ _ _ (left, top, w, _) _, (x, y), False, _) =+  (x + left, y + top + titleHeight, w, titleHeight)++titleHeight :: Double+titleHeight = 0.7++untranslated :: Double -> Double -> Event -> Event+untranslated x y (PointerPress (px, py)) = PointerPress (px - x, py - y)+untranslated x y (PointerRelease (px, py)) = PointerRelease (px - x, py - y)+untranslated x y (PointerMovement (px, py)) = PointerMovement (px - x, py - y)+untranslated _ _ other = other++-- | Adjusts the output of a parameter by passing it through a conversion+-- function.  Built-in parameters usually range from 0 to 1, and conversions+-- can be used to rescale the output to a different range.+converted :: (Double -> Double) -> Parameter -> Parameter+converted c (Parameter name val pic bounds handle) =+  Parameter name (c val) pic bounds (converted c . handle)++-- | Changes the name of an existing parameter.+renamed :: Text -> Parameter -> Parameter+renamed name (Parameter _ val pic bounds handle) =+  Parameter name val pic bounds (renamed name . handle)++-- | A 'Parameter' with a constant value, and no way to change it.+constant :: Text -> Double -> Parameter+constant name n =+  parameterOf+    name+    n+    (const id)+    id+    (const blank)+    (const (-2.5, 0, 5, 0))++-- | Builder for 'Parameter' types that are clickable and 5x1 in size.+buttonOf ::+  Text ->+  state ->+  (state -> state) ->+  (state -> Double) ->+  (state -> Picture) ->+  Parameter+buttonOf name initial click value pic =+  parameterOf+    name+    (initial, False)+    change+    (value . fst)+    ( \(state, press) ->+        pic state+          & picWhen press (colored (RGBA 0 0 0 0.3) (solidRectangle 5 1))+    )+    (const (-2.5, 0.5, 5, 1))+  where+    change (PointerPress (px, py)) (state, _)+      | abs px < 2.5, abs py < 0.5 = (state, True)+    change (PointerRelease (px, py)) (state, True)+      | abs px < 2.5, abs py < 0.5 = (click state, False)+      | otherwise = (state, False)+    change _ (state, press) = (state, press)++-- | A 'Parameter' that can be toggled between 0 (off) and 1 (on).+toggle :: Text -> Parameter+toggle name = buttonOf name False not value picture+  where+    value True = 1+    value False = 0+    picture True = dilated 0.5 $ lettering "\x2611"+    picture False = dilated 0.5 $ lettering "\x2610"++-- | A 'Parameter' that counts how many times it has been clicked.+counter :: Text -> Parameter+counter name = buttonOf name 0 (+ 1) id picture+  where+    picture _ = dilated 0.5 (lettering "Next")++-- | A 'Parameter' that can be adjusted continuously between 0 and 1.+slider :: Text -> Parameter+slider name =+  parameterOf+    name+    (0.5, False)+    change+    fst+    picture+    (const (-2.5, 0.5, 5, 1))+  where+    change (PointerPress (px, py)) (_, _)+      | abs px < 2, abs py < 0.25 = (min 1 $ max 0 $ (px + 2) / 4, True)+    change (PointerRelease _) (v, _) = (v, False)+    change (PointerMovement (px, _)) (_, True) =+      (min 1 $ max 0 $ (px + 2) / 4, True)+    change _ state = state+    picture (v, _) =+      translated (v * 4 - 2) 0 (solidRectangle 0.125 0.5)+        & solidRectangle 4 0.1++-- | A 'Parameter' that has a randomly chosen value.  It offers a button to+-- regenerate its value.+random :: Text -> Parameter+random name = buttonOf name initial (next . snd) fst picture+  where+    initial = next (unsafePerformIO newStdGen)+    picture _ = dilated 0.5 $ lettering "\x21ba Regenerate"+    next = randomR (0.0, 1.0)++-- | A 'Parameter' that changes over time. It can be paused or reset.+timer :: Text -> Parameter+timer name =+  parameterOf+    name+    (0, 1)+    change+    fst+    picture+    (const (-2.5, 0.5, 5, 1))+  where+    change (TimePassing dt) (t, r) = (t + r * dt, r)+    change (PointerPress (px, py)) (t, r)+      | abs (px - 5 / 6) < 5 / 6, abs py < 0.75 = (t, 1 - r)+      | abs (px + 5 / 6) < 5 / 6, abs py < 0.75 = (0, 0)+    change _ state = state+    picture (_, 0) =+      (translated (5 / 6) 0 $ dilated 0.5 $ lettering "\x23e9")+        & (translated (-5 / 6) 0 $ dilated 0.5 $ lettering "\x23ee")+    picture _ =+      (translated (5 / 6) 0 $ dilated 0.5 $ lettering "\x23f8")+        & (translated (-5 / 6) 0 $ dilated 0.5 $ lettering "\x23ee")++-- | A 'Parameter' that tracks the current hour, in local time.  The hour+-- is on a scale from 0 (meaning midnight) to 23 (meaning 11:00 pm).+currentHour :: Parameter+currentHour =+  parameterOf+    "hour"+    ()+    (const id)+    (\_ -> unsafePerformIO $ fromIntegral <$> todHour <$> getTimeOfDay)+    (const blank)+    (const (-2.5, 0, 5, 0))++-- | A 'Parameter' that tracks the current minute, in local time.  It+-- ranges from 0 to 59.+currentMinute :: Parameter+currentMinute =+  parameterOf+    "minute"+    ()+    (const id)+    (\_ -> unsafePerformIO $ fromIntegral <$> todMin <$> getTimeOfDay)+    (const blank)+    (const (-2.5, 0, 5, 0))++-- | A 'Parameter' that tracks the current second, in local time.  It+-- ranges from 0.0 up to (but not including) 60.0.  This includes+-- fractions of a second.  If that's not what you want, you can use+-- 'withConversion' to truncate the number.+currentSecond :: Parameter+currentSecond =+  parameterOf+    "second"+    ()+    (const id)+    (\_ -> unsafePerformIO $ realToFrac <$> todSec <$> getTimeOfDay)+    (const blank)+    (const (-2.5, 0, 5, 0))++getTimeOfDay :: IO TimeOfDay+getTimeOfDay = do+  now <- getCurrentTime+  timezone <- getCurrentTimeZone+  return (localTimeOfDay (utcToLocalTime timezone now))++titleColor :: Color+titleColor = RGBA 0.7 0.7 0.7 0.9++bgColor :: Color+bgColor = RGBA 0.8 0.85 0.95 0.8++picWhen :: Bool -> Picture -> Picture+picWhen True = id+picWhen False = const blank

@@ -29,65 +29,110 @@ import GHC.Stack import Util.EmbedAsUrl +-- | A point in two dimensions.  A point is written with the x coordinate+-- first, and the y coordinate second.  For example, (3, -2) is the point+-- with x coordinate 3 a y coordinate -2. type Point = (Double, Double) --- | Move given point by given X-axis and Y-axis offsets--- >>> translatedPoint 1 2 (10,10)--- (11.0,12.0)--- >>> translatedPoint (-1) (-2) (0,0)--- (-1.0,-2.0)+-- | Moves a given point by given x and y offsets+--+-- >>> translatedPoint 1 2 (10, 10)+-- (11.0, 12.0)+-- >>> translatedPoint (-1) (-2) (0, 0)+-- (-1.0, -2.0) translatedPoint :: Double -> Double -> Point -> Point translatedPoint tx ty (x, y) = (x + tx, y + ty) +-- | Rotates a given point by given angle, in radians+--+-- >>> rotatedPoint 45 (10, 0)+-- (7.071, 7.071) rotatedPoint :: Double -> Point -> Point rotatedPoint = rotatedVector +-- | Reflects a given point across a line through the origin at this+-- angle, in radians.  For example, an angle of 0 reflects the point+-- vertically across the x axis, while an angle of @pi / 2@ reflects the+-- 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++-- | Scales a given point by given x and y scaling factor.  Scaling by a+-- negative factor also reflects across that axis.+--+-- >>> scaledPoint 2 3 (10, 10)+-- (20, 30) scaledPoint :: Double -> Double -> Point -> Point scaledPoint kx ky (x, y) = (kx * x, ky * y) +-- | Dilates a given point by given uniform scaling factor.  Dilating by a+-- negative factor also reflects across the origin.+--+-- >>> dilatedPoint 2 (10, 10)+-- (20, 20) dilatedPoint :: Double -> Point -> Point dilatedPoint k (x, y) = (k * x, k * y) +-- | A two-dimensional vector type Vector = (Double, Double) +-- | The length of the given vector.+--+-- >>> vectorLength (10, 10)+-- 14.14 vectorLength :: Vector -> Double vectorLength (x, y) = sqrt (x*x + y*y) -{-| Given vector, calculate angle in radians that it has with the X-axis.-->>> vectorDirection (1,0)-0.0->>> vectorDirection (1,1)-0.7853981633974483->>> vectorDirection (0,1)-1.5707963267948966--}+-- | The counter-clockwise angle, in radians, that a given vector make with the X-axis+--+-- >>> vectorDirection (1,0)+-- 0.0+-- >>> vectorDirection (1,1)+-- 0.7853981633974483+-- >>> vectorDirection (0,1)+-- 1.5707963267948966 vectorDirection :: Vector -> Double vectorDirection (x, y) = atan2 y x +-- | The sum of two vectors vectorSum :: Vector -> Vector -> Vector vectorSum (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) +-- | The difference of two vectors vectorDifference :: Vector -> Vector -> Vector vectorDifference (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) +-- | Scales a given vector by a given scalar multiplier.+--+-- >>> scaledPoint 2 (10, 10)+-- (20, 20) scaledVector :: Double -> Vector -> Vector scaledVector k (x, y) = (k * x, k * y) -{-| Rotate given vector by given angle in radians-->>> rotatedVector pi (1.0, 0.0)-(-1.0,1.2246467991473532e-16)->>> rotatedVector (pi / 2) (1.0, 0.0)-(6.123233995736766e-17,1.0)- -}+-- | Rotates a given vector by a given angle in radians+--+-- >>> rotatedVector pi (1.0, 0.0)+-- (-1.0, 1.2246467991473532e-16)+-- >>> rotatedVector (pi / 2) (1.0, 0.0)+-- (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) +-- | The dot product of two vectors dotProduct :: Vector -> Vector -> Double dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 +-- | A design, diagram, or drawing that can be displayed and seen.+-- In technical terms, a picture is an assignment of a color to+-- every point of the coordinate plane.  CodeWorld contains functions+-- to create pictures from simple geometry primitives, to transform+-- existing pictures, and to combine simpler pictures into more+-- complex compositions.+--+-- 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]@@ -115,6 +160,8 @@     | 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]@@ -124,14 +171,22 @@  instance NFData Picture +-- A style in which to draw lettering.  Either 'Plain', 'Bold', or+-- 'Italic' data TextStyle-    = Plain-    | Bold-    | Italic+    = Plain   -- ^ Plain letters with no style+    | Bold    -- ^ Heavy, thick lettering used for emphasis+    | Italic  -- ^ Slanted script-like lettering used for emphasis     deriving (Generic, Show)  instance NFData TextStyle +-- A font in which to draw lettering.  There are several built-in+-- font families ('SansSerif', 'Serif', 'Monospace', 'Handwriting',+-- and 'Fancy') that can look different on each screen.  'NamedFont'+-- can be used for a specific font.  However, if the font is not+-- installed on the computer running your program, a different font+-- may be used instead. data Font     = SansSerif     | Serif@@ -284,20 +339,33 @@ translated :: HasCallStack => Double -> Double -> Picture -> Picture translated = Translate (getDebugSrcLoc callStack) --- | A picture scaled by these factors in the x and y directions.+-- | A picture scaled by these factors in the x and y directions.  Scaling+-- by a negative factoralso reflects across that axis. scaled :: HasCallStack => Double -> Double -> Picture -> Picture scaled = Scale (getDebugSrcLoc callStack)  -- | A picture scaled uniformly in all directions by this scale factor.+-- Dilating by a negative factor also reflects across the origin. dilated :: HasCallStack => Double -> Picture -> Picture dilated = Dilate (getDebugSrcLoc callStack) --- | A picture rotated by this angle.+-- | A picture rotated by this angle about the origin. -- -- Angles are in radians. rotated :: HasCallStack => Double -> Picture -> Picture rotated = Rotate (getDebugSrcLoc callStack) +-- | A picture reflected across a line through the origin at this angle, in+-- radians.  For example, an angle of 0 reflects the picture vertically+-- across the x axis, while an angle of @pi / 2@ reflects the picture+-- horizontally across the y axis.+reflected :: HasCallStack => Double -> Picture -> Picture+reflected = Reflect (getDebugSrcLoc callStack)++-- | A picture clipped to a rectangle around the origin with this width and height.+clipped :: HasCallStack => Double -> Double -> Picture -> Picture+clipped = Clip (getDebugSrcLoc callStack)+ -- A picture made by drawing these pictures, ordered from top to bottom. pictures :: HasCallStack => [Picture] -> Picture pictures = Pictures (getDebugSrcLoc callStack)@@ -342,6 +410,18 @@         "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 = Sketch (getDebugSrcLoc callStack)  getDebugSrcLoc :: CallStack -> Maybe SrcLoc getDebugSrcLoc cs = Data.List.find ((== "main") . srcLocPackage) locs

@@ -186,9 +186,12 @@     ( Reflex t,       MonadHold t m,       MonadFix m,+      TriggerEvent t m,       PerformEvent t m,+      MonadIO m,       MonadIO (Performable m),       Adjustable t m,+      NotReady t m,       PostBuild t m     ) =>     ReactiveInput t ->@@ -254,7 +257,10 @@  reactiveDebugControls ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -320,7 +326,10 @@  playPauseButton ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -354,7 +363,10 @@  stepButton ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -382,7 +394,10 @@  fastForwardButton ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -407,7 +422,10 @@  speedSlider ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -440,7 +458,10 @@  resetViewButton ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -464,7 +485,10 @@  panControls ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -493,7 +517,10 @@  zoomControls ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -520,7 +547,10 @@  zoomInButton ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -550,7 +580,10 @@  zoomOutButton ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,@@ -579,7 +612,10 @@  zoomSlider ::   ( PerformEvent t m,+    TriggerEvent t m,     Adjustable t m,+    NotReady t m,+    MonadIO m,     MonadIO (Performable m),     PostBuild t m,     MonadHold t m,