From 4b6c6f8c986dce6719bcc3b41ff8d1d5f48c841f Mon Sep 17 00:00:00 2001 From: Dierk Koenig Date: Thu, 13 Aug 2015 15:46:59 +0200 Subject: [PATCH] refactor stairs example to allow interactive execution --- Stairs.fr | 53 ++++++++--------- .../src/main/frege/org/frege/Application.fr | 4 +- client/src/main/frege/org/frege/SketchBook.fr | 59 +++++++++++++++++++ 3 files changed, 84 insertions(+), 32 deletions(-) create mode 100644 client/src/main/frege/org/frege/SketchBook.fr diff --git a/Stairs.fr b/Stairs.fr index e052366..e59ee8a 100644 --- a/Stairs.fr +++ b/Stairs.fr @@ -1,50 +1,43 @@ module Stairs where -import org.frege.JavaFX -import org.frege.AllNodes - -import fregefx.javafx.application.Platform +import org.frege.SketchBook import fregefx.javafx.scene.canvas.GraphicsContext -import fregefx.javafx.scene.canvas.Canvas -import fregefx.javafx.scene.Group -import fregefx.javafx.stage.Stage -import fregefx.javafx.scene.Scene - -withUI f = Platform.runLater =<< Runnable.new f - -paint :: (GraphicsContext -> IO()) -> IO () -paint drawing = withUI do - grp <- Group.new () - kids <- grp.getChildren - canvas <- Canvas.new 600 600 - ctx <- canvas.getGraphicsContext2D - kids.add canvas - scene <- Scene.new grp 600d 600d - stage <- Stage.new () - stage.setScene scene - stage.show - ctx.translate 300 300 -- center 0,0 - ctx.scale 1 (-1) -- mirror y axis - drawing ctx +import Data.List +--- A point on the canvas. data Point = P {x, y :: Double} + +--- The last four points that we have drawn a line to, latest first. type Trail = (Point, Point, Point, Point) +--- The initial trail. +--- Note that the starting point is tugged in a little to make the first bearing landing at the right point. start = ( P (-10) 10, P (-10) (-10), P 10 (-10), P 9.5 9.5 ) +--- Return the point that we reach when drawing a line from _start_ to _over_ and extend by 5%. bearing:: Point -> Point -> Point bearing start over = P ((over.x - start.x) * 1.05 + start.x ) ((over.y - start.y) * 1.05 + start.y) +--- How to move the trails one step forward. step :: Trail -> Trail step (first, second, third, last) = (bearing first last, first, second, third) -stairs = iterate step start +--- The infinite production of trails. +trails :: [Trail] +trails = iterate step start +--- Given a trail with a new head, paint the line that connects it to its body (= old head). connect :: GraphicsContext -> Trail -> IO () -connect ctx (nextHead,head,_,_) = ctx.strokeLine head.x head.y nextHead.x nextHead.y +connect ctx (nextHead,head,_,_) = withUI $ ctx.strokeLine head.x head.y nextHead.x nextHead.y + +--- A doodle contains all actions that when applied in sequence make up the picture. +doodle :: GraphicsContext -> [IO ()] +doodle ctx = map (connect ctx) trails + +--- Sample usage: paint the doodle at once. +fast = paint $ sequence_ . take 300 . doodle ---- a doodle contains all actions that when applied in sequence make up the picture -doodle ctx = map (connect ctx) stairs +--- Sample usage: make every second action a sleep. +slow = paint $ sequence_ . intersperse (Thread.sleep 100) . take 300 . doodle ---paint (\ctx -> sequence_ $ take 500 $ doodle ctx) diff --git a/client/src/main/frege/org/frege/Application.fr b/client/src/main/frege/org/frege/Application.fr index 34aa836..d2d1fb9 100644 --- a/client/src/main/frege/org/frege/Application.fr +++ b/client/src/main/frege/org/frege/Application.fr @@ -55,8 +55,8 @@ showUI mConsole stage = do items.add "mapM println [1..100]" items.add "fib = 1n : 1n : zipWith (+) fib (tail fib)" items.add ":l https://raw.githubusercontent.com/Dierk/frepl-gui/master/Stairs.fr" - items.add "import Stairs" - items.add "paint (\\ctx -> sequence_ $ take 500 $ doodle ctx)" + items.add "import Stairs;import org.frege.SketchBook;import Data.List" + items.add "paint $ sequence_ . take 300 . doodle" sm <- historyLV.getSelectionModel sip <- sm.selectedItemProperty diff --git a/client/src/main/frege/org/frege/SketchBook.fr b/client/src/main/frege/org/frege/SketchBook.fr new file mode 100644 index 0000000..afdc048 --- /dev/null +++ b/client/src/main/frege/org/frege/SketchBook.fr @@ -0,0 +1,59 @@ +{-- + The SketchBook provides painting surfaces on which code in the REPL can draw. + + Use it like in the _sampleUse_ function: + + > sampleUse = paint crosshair where + > crosshair ctx = withUI do + > ctx.strokeLine (-100d) 0d 100d 0d -- horizontal line + > ctx.strokeLine 0d (-100d) 0d 100d -- vertical line +-} + +module org.frege.SketchBook where + +import fregefx.javafx.application.Platform +import fregefx.javafx.scene.canvas.GraphicsContext +import fregefx.javafx.scene.canvas.Canvas +import fregefx.javafx.scene.Group +import fregefx.javafx.stage.Stage +import fregefx.javafx.scene.Scene + +import Control.Concurrent + +--- Call the _draw_ function with the graphical context of a newly created canvas. +--- The logic inside _draw_ is itself responsible for using _withUI_ when appropriate. +paint :: (GraphicsContext->IO α) -> IO α +paint draw = do + ctxHolder <- MVar.newEmpty + canvas 600 600 ctxHolder -- runs in UI thread + ctx <- ctxHolder.take -- wait until UI thread is ready + draw ctx + +--- Run any function _f_ in the JavaFX Application Thread to ensure proper painting. +--- Any code that touches a JavaFX UI component must run in this thread. +withUI :: IO () -> IO () +withUI f = Platform.runLater =<< Runnable.new f + +--- Make a frame (stage) with a canvas of the given _width_ and _height_. +--- Set the graphicsContext into the _ctxHolder_ once it is available such that other threads that wait for it can proceed. +--- The (0,0) origin is centered and y coordinates point upwards like it is conventional in mathematics. +canvas :: Double -> Double -> MVar GraphicsContext -> IO () +canvas width height ctxHolder = withUI do -- UI construction must happen inside the UI thread + grp <- Group.new () + kids <- grp.getChildren + canvas <- Canvas.new width height + ctx <- canvas.getGraphicsContext2D + kids.add canvas + scene <- Scene.new grp width height + stage <- Stage.new () + stage.setScene scene + stage.show + ctx.translate (width / 2) (height / 2) -- center 0,0 + ctx.scale 1 (-1) -- mirror y axis + ctxHolder.put ctx + +--- Example on how to use the sketchbook API that draws a crosshair. +sampleUse = paint crosshair where + crosshair ctx = withUI do + ctx.strokeLine (-100d) 0d 100d 0d + ctx.strokeLine 0d (-100d) 0d 100d