diff --git a/codeworld-api.cabal b/codeworld-api.cabal --- a/codeworld-api.cabal +++ b/codeworld-api.cabal @@ -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 diff --git a/src/CodeWorld.hs b/src/CodeWorld.hs --- a/src/CodeWorld.hs +++ b/src/CodeWorld.hs @@ -66,6 +66,8 @@ scaled, dilated, rotated, + reflected, + clipped, pictures, (<>), (&), @@ -74,6 +76,7 @@ Point, translatedPoint, rotatedPoint, + reflectedPoint, scaledPoint, dilatedPoint, Vector, diff --git a/src/CodeWorld/CanvasM.hs b/src/CodeWorld/CanvasM.hs --- a/src/CodeWorld/CanvasM.hs +++ b/src/CodeWorld/CanvasM.hs @@ -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) diff --git a/src/CodeWorld/DrawState.hs b/src/CodeWorld/DrawState.hs --- a/src/CodeWorld/DrawState.hs +++ b/src/CodeWorld/DrawState.hs @@ -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 diff --git a/src/CodeWorld/Driver.hs b/src/CodeWorld/Driver.hs --- a/src/CodeWorld/Driver.hs +++ b/src/CodeWorld/Driver.hs @@ -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 diff --git a/src/CodeWorld/Image.hs b/src/CodeWorld/Image.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Image.hs @@ -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 diff --git a/src/CodeWorld/Parameter.hs b/src/CodeWorld/Parameter.hs new file mode 100644 --- /dev/null +++ b/src/CodeWorld/Parameter.hs @@ -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 diff --git a/src/CodeWorld/Picture.hs b/src/CodeWorld/Picture.hs --- a/src/CodeWorld/Picture.hs +++ b/src/CodeWorld/Picture.hs @@ -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 diff --git a/src/CodeWorld/Reflex.hs b/src/CodeWorld/Reflex.hs --- a/src/CodeWorld/Reflex.hs +++ b/src/CodeWorld/Reflex.hs @@ -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,