From 4a9ed570e6d2c79ac7cac0a6a84d414ee658cd3e Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Mon, 8 Jun 2015 02:02:34 -0500 Subject: [PATCH] Add ask and command blocks, v1 --- src/main/main.lisp | 4 ++-- src/main/nvm.lisp | 42 +++++++++++++++++++++++++++++++++++---- src/main/package.lisp | 2 +- src/main/parse.lisp | 41 +++++++++++++++++++++++++++++++------- src/main/transpile.lisp | 9 ++++++++- src/test/main.lisp | 2 +- src/test/simpletests.lisp | 1 + 7 files changed, 85 insertions(+), 16 deletions(-) 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") -- 2.25.1