├── .gitignore ├── LICENSE ├── README.org ├── html └── index.html ├── img └── two-stars.png ├── package.json ├── packages.dhall ├── spago.dhall └── src ├── Canvas.js ├── Canvas.purs ├── CanvasInterpreter.purs ├── Language.purs └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /node_modules/ 2 | /output/ 3 | /generated-docs/ 4 | /.psc-package/ 5 | /.psc* 6 | /.purs* 7 | /.psa* 8 | /.spago 9 | /html/index.js 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Erik Post 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+title: PureScript Free Turtle interpreter 2 | 3 | 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. 4 | 5 | [[file:img/two-stars.png]] 6 | 7 | #+BEGIN_SRC purescript 8 | main :: Effect Context2D 9 | main = CanvasInterpreter.render "turtleCanvas" do 10 | color Purple 11 | star 12 | 13 | forward 40.0 14 | left 100.0 15 | 16 | color Red 17 | star 18 | 19 | star = do 20 | penDown 21 | right 144.0 22 | forward 100.0 23 | right 144.0 24 | forward 100.0 25 | right 144.0 26 | forward 100.0 27 | right 144.0 28 | forward 100.0 29 | right 144.0 30 | forward 100.0 31 | penUp 32 | #+END_SRC 33 | 34 | * Usage 35 | 36 | In your shell, type: 37 | 38 | : npm install 39 | : npm run build 40 | : npm run bundle 41 | 42 | Then point your browser to [[./html/index.html]]. 43 | -------------------------------------------------------------------------------- /html/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | PureScript Free Turtle 6 | 14 | 15 | 16 | 17 | 18 | 19 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /img/two-stars.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/epost/purescript-free-turtle/cb94dd756a1aa9c8850de1e5190369cdae1d60e7/img/two-stars.png -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-free-turtle", 3 | "version": "0.1.0", 4 | "description": "Turtle graphics language with a free monad Canvas interpreter, for educational purposes.", 5 | "main": "", 6 | "private": true, 7 | "author": "Erik Post", 8 | "license": "MIT", 9 | "scripts": { 10 | "postinstall": "npm run spago-install", 11 | "build": "spago build", 12 | "bundle": "spago bundle-app --main Main --to html/index.js", 13 | "spago-install": "spago install" 14 | }, 15 | "dependencies": { 16 | }, 17 | "devDependencies": { 18 | "purescript": "^0.13.8", 19 | "spago": "^0.16.0" 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | let upstream = 2 | https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20200922/packages.dhall sha256:5edc9af74593eab8834d7e324e5868a3d258bbab75c5531d2eb770d4324a2900 3 | 4 | in upstream 5 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | { name = 2 | "purescript-free-turtle" 3 | , dependencies = 4 | [ "console" 5 | , "effect" 6 | , "free" 7 | , "math" 8 | , "maybe" 9 | , "canvas" 10 | , "prelude" 11 | , "psci-support" 12 | , "tuples" 13 | , "transformers" 14 | ] 15 | , packages = 16 | ./packages.dhall 17 | , sources = 18 | [ "src/**/*.purs", "test/**/*.purs" ] 19 | } 20 | -------------------------------------------------------------------------------- /src/Canvas.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | // module Canvas 4 | 5 | exports.get2DContext = function(canvasId) { 6 | return function() { 7 | return document.getElementById(canvasId).getContext('2d'); 8 | }; 9 | }; 10 | 11 | exports.initContext = function(color) { 12 | return function initContext(context) { 13 | return function() { 14 | context.lineWidth = 2; 15 | context.strokeStyle = color; 16 | return context; 17 | }; 18 | }; 19 | }; 20 | 21 | exports.beginPath = function(context) { 22 | return function() { 23 | context.beginPath(); 24 | return context; 25 | }; 26 | }; 27 | 28 | exports.closePath = function(context) { 29 | return function() { 30 | context.closePath(); 31 | return context; 32 | }; 33 | }; 34 | 35 | exports.stroke = function(context) { 36 | return function() { 37 | context.stroke(); 38 | return context; 39 | }; 40 | }; 41 | 42 | exports.lineTo = function(x) { 43 | return function(y) { 44 | return function (context) { 45 | return function() { 46 | context.lineTo(x,y); 47 | return context; 48 | }; 49 | }; 50 | }; 51 | }; 52 | 53 | exports["drawFilledArc'"] = function(fillStyle) { 54 | return function (x) { 55 | return function(y) { 56 | return function(r) { 57 | return function(angleStart) { 58 | return function(angleEnd) { 59 | return function(context) { 60 | return function() { 61 | context.arc(x, y, r, angleStart, angleEnd); 62 | context.fillStyle = fillStyle; 63 | context.fill(); 64 | return context; 65 | }; 66 | }; 67 | }; 68 | }; 69 | }; 70 | }; 71 | }; 72 | }; 73 | 74 | exports.moveTo = function(x) { 75 | return function(y) { 76 | return function (context) { 77 | return function() { 78 | context.moveTo(x,y); 79 | return context; 80 | }; 81 | }; 82 | }; 83 | }; 84 | 85 | exports.setStrokeStyle = function(style) { 86 | return function (context) { 87 | return function() { 88 | context.strokeStyle = style; 89 | return context; 90 | }; 91 | }; 92 | }; 93 | -------------------------------------------------------------------------------- /src/Canvas.purs: -------------------------------------------------------------------------------- 1 | module Canvas where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe, maybe) 5 | import Effect (Effect) 6 | import Language (Distance (), Angle (), Color (..)) 7 | 8 | foreign import data Context2D :: Type 9 | 10 | type CanvasStyleString = String 11 | 12 | foreign import get2DContext :: String -> Effect Context2D 13 | 14 | foreign import initContext :: CanvasStyleString -> Context2D -> Effect Context2D 15 | 16 | foreign import beginPath :: Context2D -> Effect Context2D 17 | 18 | foreign import closePath :: Context2D -> Effect Context2D 19 | 20 | foreign import stroke :: Context2D -> Effect Context2D 21 | 22 | foreign import lineTo :: Distance -> Distance -> Context2D -> Effect Context2D 23 | 24 | drawArc :: Distance -> Distance -> Distance -> Angle -> Angle -> Context2D -> Effect Context2D 25 | drawArc = drawFilledArc' "transparent" 26 | 27 | drawFilledArc :: Maybe Color -> Distance -> Distance -> Distance -> Angle -> Angle -> Context2D -> Effect Context2D 28 | drawFilledArc col = drawFilledArc' $ maybe "" colorToCanvasStyle col 29 | 30 | foreign import drawFilledArc' :: CanvasStyleString -> Distance -> Distance -> Distance -> Angle -> Angle -> Context2D -> Effect Context2D 31 | 32 | foreign import moveTo :: Distance -> Distance -> Context2D -> Effect Context2D 33 | 34 | foreign import setStrokeStyle :: String -> Context2D -> Effect Context2D 35 | 36 | colorToCanvasStyle :: Color -> String 37 | colorToCanvasStyle col = case col of 38 | Red -> "red" 39 | Green -> "green" 40 | Blue -> "blue" 41 | Yellow -> "yellow" 42 | Purple -> "purple" 43 | Cyan -> "cyan" 44 | Magenta -> "magenta" 45 | Black -> "black" 46 | White -> "white" 47 | CustomColor str -> str 48 | -------------------------------------------------------------------------------- /src/CanvasInterpreter.purs: -------------------------------------------------------------------------------- 1 | module CanvasInterpreter where 2 | 3 | import Prelude 4 | import Canvas 5 | import Effect 6 | import Language 7 | import Control.Monad 8 | import Control.Monad.Free (runFreeM) 9 | import Control.Monad.State (State, evalState, get, modify_, put) 10 | import Data.Tuple 11 | import Data.Foldable 12 | import Math (sin, cos, pi, (%)) 13 | 14 | -------------------------------------------------------------------------------- 15 | 16 | -- | x, y, rotation, isPenDown 17 | data Turtle = Turtle Distance Distance Angle Boolean 18 | 19 | instance turtleShow :: Show Turtle where 20 | show (Turtle x y angle isPenDown) = "(Turtle " <> show x <> " " <> show y <> " " <> show angle <> " " <> show isPenDown <> ")" 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | render :: String -> TurtleProg Unit -> Effect Context2D 25 | render canvasId prog = 26 | get2DContext canvasId >>= 27 | initContext (colorToCanvasStyle Purple) >>= 28 | moveTo 0.0 0.0 >>= 29 | interpret prog 30 | 31 | interpret :: forall a. TurtleProg a -> Context2D -> Effect Context2D 32 | interpret turtleProg ctx = foldl (>>=) (pure ctx) (interpret' turtleProg) 33 | 34 | interpret' :: forall a. TurtleProg a -> Array (Context2D -> Effect Context2D) 35 | interpret' turtleProg = 36 | evalState turtleProgState (Turtle 0.0 0.0 0.0 true) 37 | where 38 | turtleProg' = const [] <$> turtleProg 39 | turtleProgState = interpret'' turtleProg' 40 | 41 | 42 | -- | A natural transformation from `TurtleProg` to `State Turtle`. 43 | interpret'' :: TurtleProg (Array (Context2D -> Effect Context2D)) 44 | -> State Turtle (Array (Context2D -> Effect Context2D)) 45 | interpret'' = runFreeM interpret 46 | 47 | where 48 | -- Pick off the outermost TurtleCmd from the TurtleProg and interpret it. 49 | interpret :: TurtleCmd (TurtleProg (Array (Context2D -> Effect Context2D))) 50 | -> State Turtle (TurtleProg (Array (Context2D -> Effect Context2D))) 51 | 52 | interpret (PenDown rest) = do 53 | Turtle x y angle p <- get 54 | put (Turtle x y angle true) 55 | pure ((\prog -> prog <> [beginPath, moveTo x y]) <$> rest) 56 | 57 | interpret (PenUp rest) = do 58 | modify_ \(Turtle x y angle _) -> Turtle x y angle false 59 | pure ((\prog -> prog <> [stroke]) <$> rest) 60 | 61 | interpret (Forward r rest) = do 62 | Turtle x y angle p <- get 63 | let x' = x + adjacent r angle 64 | y' = y + opposite r angle 65 | instr = lineTo x' y' 66 | put (Turtle x' y' angle p) 67 | pure ((\prog -> prog <> [instr]) <$> rest) 68 | 69 | interpret (Right angleDeg rest) = do 70 | let angle = rad angleDeg 71 | modify_ \(Turtle x y angle0 p) -> Turtle x y (angle0 + angle) p 72 | pure rest 73 | 74 | interpret (UseColor col rest) = do 75 | pure ((\prog -> prog <> [setStrokeStyle $ colorToCanvasStyle col]) <$> rest) 76 | 77 | interpret (Arc r arcAngleDeg rest) = do 78 | Turtle x y turtleAngle p <- get 79 | let angleEnd = turtleAngle + rad arcAngleDeg 80 | angle' = angleEnd + rad 90.0 81 | x' = x + adjacent r angleEnd 82 | y' = y + opposite r angleEnd 83 | instr = drawArc x y r turtleAngle angleEnd 84 | put (Turtle x' y' angle' p) 85 | pure (rest <#> (_ <> [instr])) 86 | 87 | adjacent r angle = r * cos angle 88 | opposite r angle = r * sin angle 89 | rad angleDegrees = (2.0 * pi * (angleDegrees % 360.0)) / 360.0 90 | -------------------------------------------------------------------------------- /src/Language.purs: -------------------------------------------------------------------------------- 1 | module Language where 2 | 3 | import Prelude 4 | import Control.Monad 5 | import Control.Monad.Free (Free, liftF) 6 | 7 | 8 | type Angle = Number 9 | type Distance = Number 10 | data Color = Red | Green | Blue | Yellow | Purple | Magenta | Cyan | Black | White | CustomColor String 11 | 12 | data TurtleCmd a = Forward Distance a 13 | | Arc Distance Angle a 14 | | Right Angle a 15 | | PenUp a 16 | | PenDown a 17 | | UseColor Color a 18 | 19 | instance functorTurtleCmd :: Functor TurtleCmd where 20 | map f (Forward dist r) = Forward dist (f r) 21 | map f (Arc radius angle r) = Arc radius angle (f r) 22 | map f (Right angle r) = Right angle (f r) 23 | map f (PenUp r) = PenUp (f r) 24 | map f (PenDown r) = PenDown (f r) 25 | map f (UseColor col r) = UseColor col (f r) 26 | 27 | instance turtleCmdShow :: (Show a) => Show (TurtleCmd a) where 28 | show x = "(TurtleCmd TODO)" 29 | 30 | type TurtleProg = Free TurtleCmd 31 | 32 | forward :: Distance -> TurtleProg Unit 33 | forward n = liftF (Forward n unit) 34 | 35 | arc :: Distance -> Angle -> TurtleProg Unit 36 | arc radius angle = liftF (Arc radius angle unit) 37 | 38 | right :: Angle -> TurtleProg Unit 39 | right angle = liftF (Right angle unit) 40 | 41 | left :: Angle -> TurtleProg Unit 42 | left angle = right (360.0 - angle) 43 | 44 | penUp :: TurtleProg Unit 45 | penUp = liftF (PenUp unit) 46 | 47 | penDown :: TurtleProg Unit 48 | penDown = liftF (PenDown unit) 49 | 50 | color :: Color -> TurtleProg Unit 51 | color col = liftF (UseColor col unit) 52 | -------------------------------------------------------------------------------- /src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | import Language 5 | import Canvas (Context2D) 6 | import CanvasInterpreter as CanvasInterpreter 7 | import Control.Monad 8 | import Effect (Effect) 9 | 10 | main :: Effect Context2D 11 | main = CanvasInterpreter.render "turtleCanvas" do 12 | color Purple 13 | star 14 | 15 | forward 40.0 16 | left 100.0 17 | 18 | color Red 19 | star 20 | 21 | forward 40.0 22 | left 100.0 23 | 24 | color Green 25 | star 26 | 27 | star = do 28 | penDown 29 | right 144.0 30 | forward 100.0 31 | right 144.0 32 | forward 100.0 33 | right 144.0 34 | forward 100.0 35 | right 144.0 36 | forward 100.0 37 | right 144.0 38 | forward 100.0 39 | penUp 40 | --------------------------------------------------------------------------------