From cb94dd756a1aa9c8850de1e5190369cdae1d60e7 Mon Sep 17 00:00:00 2001 From: Erik Post Date: Thu, 1 Oct 2020 23:34:09 +0200 Subject: [PATCH] Rearrange code a bit for clarity. --- README.org | 13 ++-- src/CanvasInterpreter.purs | 119 ++++++++++++++++++------------------- src/Language.purs | 4 +- src/Main.purs | 4 +- 4 files changed, 71 insertions(+), 69 deletions(-) diff --git a/README.org b/README.org index 5846596..43dff34 100644 --- a/README.org +++ b/README.org @@ -1,21 +1,23 @@ #+title: PureScript Free Turtle interpreter -A demonstration of a Turtle interpreter based on the Free monad, with HTML Canvas graphics support. +A simple Turtle graphics system implemented using a ~Free~ monad, intended for educational purposes. It comes with an interpreter that translates programs in the Turtle language to HTML canvas graphics. [[file:img/two-stars.png]] #+BEGIN_SRC purescript -main :: Context2DEff -main = renderTurtleProgOnCanvas "turtleCanvas" $ do +main :: Effect Context2D +main = CanvasInterpreter.render "turtleCanvas" do + color Purple star - penUp + forward 40.0 left 100.0 - penDown + color Red star star = do + penDown right 144.0 forward 100.0 right 144.0 @@ -26,6 +28,7 @@ star = do forward 100.0 right 144.0 forward 100.0 + penUp #+END_SRC * Usage diff --git a/src/CanvasInterpreter.purs b/src/CanvasInterpreter.purs index 6b1214f..d475994 100644 --- a/src/CanvasInterpreter.purs +++ b/src/CanvasInterpreter.purs @@ -11,80 +11,79 @@ import Data.Tuple import Data.Foldable import Math (sin, cos, pi, (%)) +-------------------------------------------------------------------------------- + -- | x, y, rotation, isPenDown data Turtle = Turtle Distance Distance Angle Boolean instance turtleShow :: Show Turtle where show (Turtle x y angle isPenDown) = "(Turtle " <> show x <> " " <> show y <> " " <> show angle <> " " <> show isPenDown <> ")" +-------------------------------------------------------------------------------- -interpretTurtleProg :: forall a. TurtleProg a -> Context2D -> Effect Context2D -interpretTurtleProg turtleProg ctx = foldl (>>=) (pure ctx) (interpretTurtleProg' turtleProg) - +render :: String -> TurtleProg Unit -> Effect Context2D +render canvasId prog = + get2DContext canvasId >>= + initContext (colorToCanvasStyle Purple) >>= + moveTo 0.0 0.0 >>= + interpret prog -interpretTurtleProg' :: forall a. TurtleProg a -> Array (Context2D -> Effect Context2D) -interpretTurtleProg' turtleProg = +interpret :: forall a. TurtleProg a -> Context2D -> Effect Context2D +interpret turtleProg ctx = foldl (>>=) (pure ctx) (interpret' turtleProg) +interpret' :: forall a. TurtleProg a -> Array (Context2D -> Effect Context2D) +interpret' turtleProg = evalState turtleProgState (Turtle 0.0 0.0 0.0 true) - - where turtleProg' = const [] <$> turtleProg - turtleProgState = interpretTurtleProg'' turtleProg' + where + turtleProg' = const [] <$> turtleProg + turtleProgState = interpret'' turtleProg' -- | A natural transformation from `TurtleProg` to `State Turtle`. -interpretTurtleProg'' :: TurtleProg (Array (Context2D -> Effect Context2D)) - -> State Turtle (Array (Context2D -> Effect Context2D)) -interpretTurtleProg'' = runFreeM interpret - - -- pick off the outermost TurtleCmd from the TurtleProg and process it - where interpret :: TurtleCmd (TurtleProg (Array (Context2D -> Effect Context2D))) - -> State Turtle (TurtleProg (Array (Context2D -> Effect Context2D))) - - interpret (Forward r rest) = do - Turtle x y angle p <- get - let x' = x + adjacent r angle - y' = y + opposite r angle - instr = lineTo x' y' - put (Turtle x' y' angle p) - - pure ((\prog -> prog <> [instr]) <$> rest) - - interpret (Arc r arcAngleDeg rest) = do - Turtle x y turtleAngle p <- get - let angleEnd = turtleAngle + rad arcAngleDeg - angle' = angleEnd + rad 90.0 - x' = x + adjacent r angleEnd - y' = y + opposite r angleEnd - instr = drawArc x y r turtleAngle angleEnd - - put (Turtle x' y' angle' p) - pure (rest <#> (_ <> [instr])) - - interpret (Right angleDeg rest) = do - let angle = rad angleDeg - modify_ \(Turtle x y angle0 p) -> Turtle x y (angle0 + angle) p - pure rest - - interpret (PenUp rest) = do - modify_ $ \(Turtle x y angle _) -> Turtle x y angle false - pure ((\prog -> prog <> [stroke]) <$> rest) - - interpret (PenDown rest) = do - Turtle x y angle p <- get - put (Turtle x y angle true) - pure ((\prog -> prog <> [beginPath, moveTo x y]) <$> rest) - - interpret (UseColor col rest) = do - pure ((\prog -> prog <> [setStrokeStyle $ colorToCanvasStyle col]) <$> rest) - +interpret'' :: TurtleProg (Array (Context2D -> Effect Context2D)) + -> State Turtle (Array (Context2D -> Effect Context2D)) +interpret'' = runFreeM interpret + + where + -- Pick off the outermost TurtleCmd from the TurtleProg and interpret it. + interpret :: TurtleCmd (TurtleProg (Array (Context2D -> Effect Context2D))) + -> State Turtle (TurtleProg (Array (Context2D -> Effect Context2D))) + + interpret (PenDown rest) = do + Turtle x y angle p <- get + put (Turtle x y angle true) + pure ((\prog -> prog <> [beginPath, moveTo x y]) <$> rest) + + interpret (PenUp rest) = do + modify_ \(Turtle x y angle _) -> Turtle x y angle false + pure ((\prog -> prog <> [stroke]) <$> rest) + + interpret (Forward r rest) = do + Turtle x y angle p <- get + let x' = x + adjacent r angle + y' = y + opposite r angle + instr = lineTo x' y' + put (Turtle x' y' angle p) + pure ((\prog -> prog <> [instr]) <$> rest) + + interpret (Right angleDeg rest) = do + let angle = rad angleDeg + modify_ \(Turtle x y angle0 p) -> Turtle x y (angle0 + angle) p + pure rest + + interpret (UseColor col rest) = do + pure ((\prog -> prog <> [setStrokeStyle $ colorToCanvasStyle col]) <$> rest) + + interpret (Arc r arcAngleDeg rest) = do + Turtle x y turtleAngle p <- get + let angleEnd = turtleAngle + rad arcAngleDeg + angle' = angleEnd + rad 90.0 + x' = x + adjacent r angleEnd + y' = y + opposite r angleEnd + instr = drawArc x y r turtleAngle angleEnd + put (Turtle x' y' angle' p) + pure (rest <#> (_ <> [instr])) adjacent r angle = r * cos angle opposite r angle = r * sin angle rad angleDegrees = (2.0 * pi * (angleDegrees % 360.0)) / 360.0 - -renderTurtleProgOnCanvas :: String -> TurtleProg Unit -> Effect Context2D -renderTurtleProgOnCanvas canvasId prog = - get2DContext canvasId >>= - initContext (colorToCanvasStyle Purple) >>= - moveTo 0.0 0.0 >>= - interpretTurtleProg prog diff --git a/src/Language.purs b/src/Language.purs index dee559e..df1ad6f 100644 --- a/src/Language.purs +++ b/src/Language.purs @@ -16,7 +16,7 @@ data TurtleCmd a = Forward Distance a | PenDown a | UseColor Color a -instance turtleCmd :: Functor TurtleCmd where +instance functorTurtleCmd :: Functor TurtleCmd where map f (Forward dist r) = Forward dist (f r) map f (Arc radius angle r) = Arc radius angle (f r) map f (Right angle r) = Right angle (f r) @@ -25,7 +25,7 @@ instance turtleCmd :: Functor TurtleCmd where map f (UseColor col r) = UseColor col (f r) instance turtleCmdShow :: (Show a) => Show (TurtleCmd a) where - show x = "(TurtleCmd)" + show x = "(TurtleCmd TODO)" type TurtleProg = Free TurtleCmd diff --git a/src/Main.purs b/src/Main.purs index 13b6ce9..bac0565 100644 --- a/src/Main.purs +++ b/src/Main.purs @@ -3,12 +3,12 @@ module Main where import Prelude import Language import Canvas (Context2D) -import CanvasInterpreter +import CanvasInterpreter as CanvasInterpreter import Control.Monad import Effect (Effect) main :: Effect Context2D -main = renderTurtleProgOnCanvas "turtleCanvas" $ do +main = CanvasInterpreter.render "turtleCanvas" do color Purple star