From: Frank Duncan <frank@kank.net>
Date: Mon, 8 Jun 2015 07:02:34 +0000 (-0500)
Subject: Add ask and command blocks, v1
X-Git-Tag: v0.0.0~13
X-Git-Url: https://code.consxy.com/gitweb/?a=commitdiff_plain;h=4a9ed570e6d2c79ac7cac0a6a84d414ee658cd3e;p=clnl

Add ask and command blocks, v1
---

diff --git a/src/main/main.lisp b/src/main/main.lisp
index f5a47b0..00107fa 100644
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -6,7 +6,7 @@
  (let*
   ((lexed-ast (let ((ast (cl-nl.lexer:lex str))) (format t "Via lexing, AST for ~S became ~S~%" str ast) ast))
    (parsed-ast (let ((ast (cl-nl.parser:parse lexed-ast))) (format t "Via parsing, AST for ~S became ~S~%" lexed-ast ast) ast))
-   (transpiled-ast (let ((ast (cl-nl.transpiler:transpile-command-block parsed-ast))) (format t "Via transpiling, AST for ~S became ~S~%" parsed-ast ast) ast)))
+   (transpiled-ast (let ((ast (cl-nl.transpiler:transpile-commands parsed-ast))) (format t "Via transpiling, AST for ~S became ~S~%" parsed-ast ast) ast)))
   (eval transpiled-ast)))
 
 (defun p (result) result)
@@ -22,4 +22,4 @@
  )
 
 (defun run-commands (cmds)
- (eval (cl-nl.transpiler:transpile-command-block (cl-nl.parser:parse  (cl-nl.lexer:lex cmds)))))
+ (eval (cl-nl.transpiler:transpile-commands (cl-nl.parser:parse  (cl-nl.lexer:lex cmds)))))
diff --git a/src/main/nvm.lisp b/src/main/nvm.lisp
index de63bf1..091bfe4 100644
--- a/src/main/nvm.lisp
+++ b/src/main/nvm.lisp
@@ -4,8 +4,10 @@
 
 (defvar *current-id* 0)
 
-(defstruct turtle who color heading)
+(defstruct turtle who color heading xcor ycor)
 (defvar *turtles* nil)
+(defvar *myself* nil)
+(defvar *self* nil)
 
 (defun show (n)
  (format t "Showing: ~A~%" n))
@@ -14,10 +16,39 @@
  (push
   (make-turtle :who *current-id*
                :color (coerce (+ 5 (* 10 (cl-nl.random:next-int 14))) 'double-float)
-               :heading (coerce (cl-nl.random:next-int 360) 'double-float))
+               :heading (coerce (cl-nl.random:next-int 360) 'double-float)
+               :xcor 0d0
+               :ycor 0d0)
   *turtles*)
  (incf *current-id*))
 
+(defun turtles () *turtles*)
+
+(defun ask (agent-set fn)
+ (mapcar
+  (lambda (agent)
+   (let
+    ((*myself* *self*)
+     (*self* agent))
+    (funcall fn)))
+  (shuffle agent-set)))
+
+(defun shuffle (agent-set)
+ (let
+  ((copy (copy-list agent-set)))
+  (append
+   (loop for i to (- (length copy) 2)
+         for idx = (+ i (cl-nl.random:next-int (- (length copy) i)))
+         for next = (nth idx copy)
+         do (setf (nth idx copy) (nth i copy))
+         collect next)
+   (last copy))))
+
+(defun fd (n)
+ (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude"))
+ (setf (turtle-xcor *self*) (+ (turtle-xcor *self*) (sin (* pi (/ (turtle-heading *self*) 180)))))
+ (setf (turtle-ycor *self*) (+ (turtle-ycor *self*) (cos (* pi (/ (turtle-heading *self*) 180))))))
+
 (defun create-turtles (n)
  (loop for i from 1 to n do (create-turtle)))
 
@@ -47,10 +78,13 @@
     (mapcar
      (lambda (turtle)
       (format nil
-       "\"~A\",\"~A\",\"~A\",\"0\",\"0\",\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""
+       "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""
        (turtle-who turtle)
        (format-num (turtle-color turtle))
-       (format-num (turtle-heading turtle))))
+       (format-num (turtle-heading turtle))
+       (format-num (turtle-xcor turtle))
+       (format-num (turtle-ycor turtle))
+       ))
      (reverse *turtles*)))
    (format nil "~S" "PATCHES")
    "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
diff --git a/src/main/package.lisp b/src/main/package.lisp
index ff2f077..a6ca2df 100644
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -12,7 +12,7 @@
 
 (defpackage #:cl-nl.transpiler
  (:use :common-lisp)
- (:export :transpile-command-block))
+ (:export :transpile-commands))
 
 (defpackage #:cl-nl.nvm
  (:use :common-lisp)
diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 40be292..a88d833 100644
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -24,21 +24,17 @@
 
 (defun prim-name (prim) (getf prim :name))
 (defun prim-num-args (prim) (length (getf prim :args)))
+(defun prim-args (prim) (getf prim :args))
 
 (defun find-prim (symb) (find symb *prims* :key #'prim-name))
 
-; We don't care if it's a command!
-;(defun is-command (symb)
-; (let
-;  ((prim (find-prim symb)))
-; (and prim (eql :command (getf prim :type)))))
-  
 ; Make this only as complicated as it needs to be, letting it grow
 ; as we take on more and more of the language
 (defun parse (lexed-ast)
  (cond
   ((not lexed-ast) nil)
   ((numberp (car lexed-ast)) (cons (coerce (car lexed-ast) 'double-float) (parse (cdr lexed-ast))))
+  ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast)))
   ((and (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))
    (let*
     ((prim (find-prim (car lexed-ast)))
@@ -47,10 +43,38 @@
     (cons
      (cons
       (prim-name prim)
-      (butlast parsed-remainder (- (length parsed-remainder) num-args)))
+      (mapcar
+       #'help-arg
+       (prim-args prim) 
+       (butlast parsed-remainder (- (length parsed-remainder) num-args))))
      (nthcdr num-args parsed-remainder))))
   (t (error "Couldn't parse ~S" lexed-ast))))
 
+(defun help-arg (arg-type arg)
+ (case arg-type
+  (:command-block
+   (if (not (and (consp arg) (eql 'block (car arg))))
+       (error "Required a block, but found a ~A" arg)
+       (cons :command-block (cdr arg))))
+  (t arg)))
+
+(defun parse-block (tokens)
+ (multiple-value-bind (in-block after-block) (find-closing-bracket tokens)
+  (cons
+   (cons
+    'block
+    (parse in-block))
+   (parse after-block))))
+
+(defun find-closing-bracket (tokens &optional (depth 0))
+ (cond
+  ((not tokens) (error "Failed to find a matching closing bracket"))
+  ((and (eql :] (car tokens)) (= depth 0)) (values nil (cdr tokens)))
+  (t (multiple-value-bind
+      (in-block after-block)
+      (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
+      (values (cons (car tokens) in-block) after-block)))))
+
 (defmacro defprim (name args)
  `(push
    (list :name ,name :args ',args)
@@ -60,5 +84,8 @@
 ; Current list of argument types we accept:
 ; - :number
 ; - t - any type
+(defprim :ask (:agentset :command-block))
 (defprim :crt (:number))
+(defprim :fd (:number))
 (defprim :show (t))
+(defprim :turtles ())
diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index 80fe4af..a9cf77b 100644
--- a/src/main/transpile.lisp
+++ b/src/main/transpile.lisp
@@ -21,7 +21,7 @@
 
 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
 ; For now, it's just a 
-(defun transpile-command-block (parsed-ast)
+(defun transpile-commands (parsed-ast)
  `(progn
    ,@(mapcar #'transpile-command parsed-ast)))
 
@@ -37,15 +37,22 @@
   ((numberp reporter) reporter) ; The parser converts to double for us
   ((symbolp reporter) reporter) ; The parser should have checked that having a symbol here is ok
   ((not (listp reporter)) (error "Expected a statement of some sort"))
+  ((eql :command-block (car reporter)) (transpile-command-block reporter))
   ((not (find-prim (car reporter))) (error "Couldn't find the reporter for ~S" (car reporter)))
   ((not (is-reporter (find-prim (car reporter)))) (error "Expected reporter, got ~S" (car reporter)))
   (t `(,(prim-func (find-prim (car reporter))) ,@(mapcar #'transpile-reporter (cdr reporter))))))
 
+(defun transpile-command-block (block)
+ `(lambda () ,@(mapcar #'transpile-command (cdr block))))
+
 (defmacro defprim (name type nvm-func)
  `(push
    (list :name ,name :type ,type :func ',nvm-func)
    *prims*))
 
 ; We count on the parser to handle arguemnts for us, when collating things.
+(defprim :ask :command cl-nl.nvm::ask)
 (defprim :crt :command cl-nl.nvm::create-turtles)
+(defprim :fd :command cl-nl.nvm::fd)
 (defprim :show :command cl-nl.nvm::show)
+(defprim :turtles :reporter cl-nl.nvm::turtles)
diff --git a/src/test/main.lisp b/src/test/main.lisp
index 38ec2ed..dbcbd58 100644
--- a/src/test/main.lisp
+++ b/src/test/main.lisp
@@ -20,7 +20,7 @@
 
 (defun run-all-tests ()
  (format t "~%Here we goooooooo~%")
- (run-tests *tests*))
+ (run-tests (reverse *tests*)))
   
 (defun run-tests-matching (match)
  (run-tests (remove-if-not (lambda (test-name) (cl-ppcre:scan (format nil "^~A$" match) test-name)) *tests* :key #'car)))
diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp
index 55aee65..cb7bbed 100644
--- a/src/test/simpletests.lisp
+++ b/src/test/simpletests.lisp
@@ -3,3 +3,4 @@
 (defsimpletest "Nothing" "" "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
 (defsimpletest "Simple crt" "crt 1" "2F08B31AC06C9D5339E6B3E953C2B4B71FDB9CDE")
 (defsimpletest "Simple crt 2" "crt 5" "9FE588C2749CD9CE66CB0EA451EFB80476E881FB")
+(defsimpletest "Simple crt and fd" "crt 5 ask turtles [ fd 1 ]" "BEB43404EDC7852985A9A7FC312481785FE553A0")