diff --git a/Gruntfile.js b/Gruntfile.js new file mode 100644 index 0000000..883d58d --- /dev/null +++ b/Gruntfile.js @@ -0,0 +1,67 @@ +module.exports = function(grunt) { + + "use strict"; + + grunt.initConfig({ + + libFiles: [ + "src/**/*.purs", + "bower_components/purescript-*/src/**/*.purs" + ], + + clean: ["tmp", "output"], + + pscMake: { + lib: { + src: ["<%=libFiles%>"] + }, + tests: { + src: ["tests/Tests.purs", "<%=libFiles%>"] + } + }, + + dotPsci: ["<%=libFiles%>"], + + copy: [ + { + expand: true, + cwd: "output", + src: ["**"], + dest: "tmp/node_modules/" + }, { + src: ["js/index.js"], + dest: "tmp/index.js" + } + ], + + execute: { + tests: { + src: "tmp/index.js" + } + }, + + // produce a single js file + psc: { + examples: { + options: { + module: ["BrowserMain"], + main: false + }, + src: ["<%=libFiles%>"], + dest: "tmp/BrowserMain.js" + } + } + }); + + grunt.loadNpmTasks("grunt-contrib-copy"); + grunt.loadNpmTasks("grunt-contrib-clean"); + grunt.loadNpmTasks("grunt-execute"); + grunt.loadNpmTasks("grunt-purescript"); + + grunt.registerTask("test", ["pscMake:tests", "copy", "execute:tests"]); + grunt.registerTask("make", ["pscMake:lib", "dotPsci"]); + grunt.registerTask("default", + // ["clean", "make", "test"] + ["clean", "make", "psc:examples"] + ); +}; diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c0600b7 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2014 Erik Post + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/README.org b/README.org new file mode 100644 index 0000000..6bd9464 --- /dev/null +++ b/README.org @@ -0,0 +1,26 @@ +#+title: PureScript Free Turtle interpreter + +A demonstration of a Turtle interpreter based on the Free monad, with HTML Canvas graphics support. + +Example: + +#+BEGIN_SRC purescript +main :: Context2DEff +main = + get2DContext "turtleCanvas" >>= + beginStroke >>= + compileTurtleProg star >>= + endStroke + +star = do + right 144 + forward 100 + right 144 + forward 100 + right 144 + forward 100 + right 144 + forward 100 + right 144 + forward 100 +#+END_SRC diff --git a/bower.json b/bower.json new file mode 100644 index 0000000..1c5b78b --- /dev/null +++ b/bower.json @@ -0,0 +1,27 @@ +{ + "name": "purescript-free-turtle", + "description": "A demonstration of a Turtle interpreter based on the Free monad, with HTML Canvas graphics support.", + "keywords": ["purescript"], + "ignore": [ + "**/.*", + "bower_components", + "node_modules", + "output", + "tests", + "js", + "tmp", + "bower.json", + "Gruntfile.js", + "package.json" + ], + "dependencies": { + "purescript-free" : "*", + "purescript-math" : "*", + "purescript-arrays" : "*", + "purescript-maybe" : "*", + "purescript-foldable-traversable" : "*" + }, + "devDependencies": { + "purescript-quickcheck" : "*" + } +} diff --git a/html/index.html b/html/index.html new file mode 100644 index 0000000..93049de --- /dev/null +++ b/html/index.html @@ -0,0 +1,34 @@ + + + + + + PureScript Free Turtle + + + + + + + + + diff --git a/package.json b/package.json new file mode 100644 index 0000000..809a2ca --- /dev/null +++ b/package.json @@ -0,0 +1,16 @@ +{ + "name": "purescript-free-turtle", + "version": "0.1.0", + "description": "A demonstration of a Turtle interpreter based on the Free monad, with HTML Canvas graphics support.", + "main": "", + "private": true, + "author": "Erik Post", + "license": "MIT", + "dependencies": { + "grunt": "~0.4.4", + "grunt-contrib-copy": "~0.5.0", + "grunt-contrib-clean": "~0.5.0", + "grunt-execute": "~0.1.5", + "grunt-purescript": "~0.5.0" + } +} diff --git a/src/BrowserMain.purs b/src/BrowserMain.purs new file mode 100644 index 0000000..0ada6de --- /dev/null +++ b/src/BrowserMain.purs @@ -0,0 +1,31 @@ +module BrowserMain where + +import Language +import CanvasCompiler +import Canvas +import Util +import Control.Monad +import Control.Monad.Eff +import Debug.Trace + + +main :: Context2DEff +main = + get2DContext "turtleCanvas" >>= + beginStroke >>= + compileTurtleProg star >>= + endStroke + +star = do + right 144 + forward 100 + right 144 + forward 100 + right 144 + forward 100 + right 144 + forward 100 + right 144 + forward 100 + +star' = forward 100 >> star diff --git a/src/Canvas.purs b/src/Canvas.purs new file mode 100644 index 0000000..d3f2c0d --- /dev/null +++ b/src/Canvas.purs @@ -0,0 +1,57 @@ +module Canvas where + +import Control.Monad.Eff + +foreign import data Context2D :: * +foreign import data DOM :: ! + +type Context2DEff = Eff (dom :: DOM) Context2D + + +foreign import get2DContext + """ + function get2DContext(canvasId) { + return function() { + return document.getElementById(canvasId).getContext('2d'); + }; + } + """ :: forall eff. String -> Context2DEff + + +foreign import beginStroke + """ + function beginStroke(context) { + return function() { + context.beginPath(); + context.lineWidth = 2; + context.strokeStyle = 'purple'; + context.moveTo(0, 0); + return context; + }; + } + """ :: forall eff. Context2D -> Context2DEff + +foreign import endStroke + """ + function endStroke(context) { + return function() { + context.stroke(); + return context; + }; + } + """ :: forall eff. Context2D -> Context2DEff + +foreign import lineTo + """ + function lineTo(x) { + return function(y) { + return function (context) { + return function() { + //console.log('executing lineTo(', x, ',', y, ')'); + context.lineTo(x,y); + return context; + }; + }; + }; + } + """ :: Number -> Number -> Context2D -> Context2DEff diff --git a/src/CanvasCompiler.purs b/src/CanvasCompiler.purs new file mode 100644 index 0000000..7f629f1 --- /dev/null +++ b/src/CanvasCompiler.purs @@ -0,0 +1,68 @@ +module CanvasCompiler where + +import Canvas +import Language +import Control.Monad +import Control.Monad.Free +import Control.Monad.State +import Control.Monad.Trans +import Control.Monad.State.Class +import Control.Monad.Eff +import Data.Tuple +import Data.Foldable +import Math (sin, cos, pi) + + +-- | x, y, rotation +data Turtle = Turtle Number Number Angle + +instance turtleShow :: Show Turtle where + show (Turtle x y angle) = "(Turtle " ++ show x ++ " " ++ show y ++ " " ++ show angle ++ ")" + + +compileTurtleProg :: forall a. TurtleProg a -> Context2D -> Context2DEff +compileTurtleProg turtleProg ctx = foldl (>>=) (pure ctx) (compileTurtleProg' turtleProg) + + +compileTurtleProg' :: forall a. TurtleProg a -> [Context2D -> Context2DEff] +compileTurtleProg' turtleProg = + + evalState turtleProgState (Turtle 0 0 0) + + where turtleProg' = const [] <$> turtleProg + turtleProgState = compileTurtleProg'' turtleProg' + + +compileTurtleProg'' :: TurtleProg [Context2D -> Context2DEff] + -> State Turtle [Context2D -> Context2DEff] +compileTurtleProg'' = goM compileCmd + + -- pick off the outermost TurtleCmd from the TurtleProg and process it + where compileCmd :: TurtleCmd (TurtleProg [Context2D -> Context2DEff]) + -> State Turtle (TurtleProg [Context2D -> Context2DEff]) + + compileCmd (Forward r rest) = do + + Turtle x y angle <- get + + let x' = x + adjacent r angle + y' = y + opposite r angle + instr = lineTo x' y' + + put (Turtle x' y' angle) + + return ((\prog -> prog ++ [instr]) <$> rest) + + + compileCmd (Right angleDeg rest) = do + + let angle = rad angleDeg + + modify $ \(Turtle x y angle0) -> Turtle x y (angle0 + angle) + + return rest + + +adjacent r angle = r * cos angle +opposite r angle = r * sin angle +rad angleDegrees = (2 * pi * (angleDegrees % 360)) / 360 diff --git a/src/Language.purs b/src/Language.purs new file mode 100644 index 0000000..4a28cce --- /dev/null +++ b/src/Language.purs @@ -0,0 +1,30 @@ +module Language where + +import Control.Monad +import Control.Monad.Free +import Control.Monad.State +import Control.Monad.Trans +import Control.Monad.State.Class + + +type Angle = Number + +data TurtleCmd a = Forward Number a + | Right Angle a + +instance turtleCmd :: Functor TurtleCmd where + (<$>) f (Forward dist r) = Forward dist (f r) + (<$>) f (Right angle r) = Right angle (f r) + +instance turtleCmdShow :: (Show a) => Show (TurtleCmd a) where + show x = "(TurtleCmd)" + +type TurtleProg = Free TurtleCmd + +forward :: Number -> forall a. (TurtleProg Unit) +forward n = liftF (Forward n unit) + +right :: Angle -> forall a. (TurtleProg Unit) +right angle = liftF (Right angle unit) + +left angle = right (360 - angle) diff --git a/src/Util.purs b/src/Util.purs new file mode 100644 index 0000000..4d492d7 --- /dev/null +++ b/src/Util.purs @@ -0,0 +1,7 @@ +module Util where + +infixl 1 >> + +(>>) :: forall m a b. (Monad m) => m a -> m b -> m b +(>>) ma mb = ma >>= (\_ -> mb) +