Add ask and command blocks, v1

diff --git a/src/main/main.lisp b/src/main/main.lisp
index f5a47b0627dce17fcbb231abd26ba2cc527f3d16..00107faf2ee0ecbb563b267cd5bf798d34803b64 100644 (file)
--- 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))
  (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)
   (eval transpiled-ast)))
 
 (defun p (result) result)


@@ -22,4 +22,4 @@
  )
 
 (defun run-commands (cmds)
  )
 
 (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 de63bf1fd932229c70b6a9d8e24654f89a5e2946..091bfe44c7244bb1dfe79eff23da52655e9de380 100644 (file)
--- a/src/main/nvm.lisp
+++ b/src/main/nvm.lisp
@@ -4,8 +4,10 @@
 
 (defvar *current-id* 0)
 
 
 (defvar *current-id* 0)
 

-(defstruct turtle who color heading)
+(defstruct turtle who color heading xcor ycor)

 (defvar *turtles* nil)
 (defvar *turtles* nil)

+(defvar *myself* nil)
+(defvar *self* nil)

 
 (defun show (n)
  (format t "Showing: ~A~%" n))
 
 (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)
  (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*))
 
   *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)))
 
 (defun create-turtles (n)
  (loop for i from 1 to n do (create-turtle)))
 


@@ -47,10 +78,13 @@
     (mapcar
      (lambda (turtle)
       (format nil
     (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))
        (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\""
      (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 ff2f077bc0203d5ef95a7d3c6e6a41430c43315c..a6ca2df874f374bb4b2b56d6956940501f31f6ba 100644 (file)
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -12,7 +12,7 @@
 
 (defpackage #:cl-nl.transpiler
  (:use :common-lisp)
 
 (defpackage #:cl-nl.transpiler
  (:use :common-lisp)

- (:export :transpile-command-block))
+ (:export :transpile-commands))

 
 (defpackage #:cl-nl.nvm
  (:use :common-lisp)
 
 (defpackage #:cl-nl.nvm
  (:use :common-lisp)

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 40be292d3d97fe2ab18955627409aaac2cfe35d8..a88d833c493f3b2b1ca6148843238852f953874e 100644 (file)
--- 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-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))
 
 
 (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))))
 ; 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)))
   ((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)
     (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))))
 
      (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)
 (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
 ; Current list of argument types we accept:
 ; - :number
 ; - t - any type

+(defprim :ask (:agentset :command-block))

 (defprim :crt (:number))
 (defprim :crt (:number))

+(defprim :fd (:number))

 (defprim :show (t))
 (defprim :show (t))

+(defprim :turtles ())

diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index 80fe4afe9b4220059dbdd04089550445f4ef3820..a9cf77b128d2465ee20baf862f6b358a518aa2c2 100644 (file)
--- 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 
 
 ; 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)))
 
  `(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"))
   ((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))))))
 
   ((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.
 (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 :crt :command cl-nl.nvm::create-turtles)

+(defprim :fd :command cl-nl.nvm::fd)

 (defprim :show :command cl-nl.nvm::show)
 (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 38ec2ed5a3994cd9d5d35c4d18ba122b86911798..dbcbd58529cb8b0c45ee6c09eef384c22c0d1982 100644 (file)
--- a/src/test/main.lisp
+++ b/src/test/main.lisp
@@ -20,7 +20,7 @@
 
 (defun run-all-tests ()
  (format t "~%Here we goooooooo~%")
 
 (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)))
   
 (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 55aee65e7e7165ad9c15362758e0680f853927a9..cb7bbed041d4278658e49d9a23ea0e5d6dcd691f 100644 (file)
--- 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 "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")