Initial commit.

epost · Oct 27, 2014 · 0612022 · 0612022
commit 0612022
Show file tree

Hide file tree

Showing 11 changed files with 383 additions and 0 deletions.
diff --git a/Gruntfile.js 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
@@ -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.
diff --git a/README.org 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
@@ -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
@@ -0,0 +1,34 @@
+<!DOCTYPE html>
+<html>
+<head>
+    <meta charset=utf-8 />
+    <script src="BrowserMain.js"></script>
+    <title>PureScript Free Turtle</title>
+    <style type="text/css">
+     body { 
+       background: #eee;
+     }
+     canvas { 
+       background: #fff;
+     }
+    </style>
+</head>
+<body>
+    <canvas id="turtleCanvas">
+    </canvas>
+
+    <script type="text/javascript">
+        var canvas = document.getElementById('turtleCanvas'),
+            context = canvas.getContext('2d');
+
+        // set canvas dimensions through js; doing it by css only will stretch the drawing
+        canvas.setAttribute('width',  window.innerWidth);
+        canvas.setAttribute('height', 400);
+
+        // put origin at center
+        context.translate(canvas.width/2, canvas.height/2);
+
+        PS.BrowserMain.main();
+    </script>
+</body>
+</html>
diff --git a/package.json 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)
+