Prims - Optional arguments

diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp
index cd494a7be4c012e57b8bd6067662a3b6bbe48979..d93089e32e7b1bacb53a7581d4cb6ef55ce197bd 100644 (file)
--- a/src/main/nvm/base.lisp
+++ b/src/main/nvm/base.lisp
@@ -20,6 +20,9 @@
   ((and (listp agentset) (eql :agentset (car agentset))) (cdr agentset))
   (t (error "Doesn't seem to be an agentset: ~A" agentset))))
 
+(defun list->agentset (list)
+ (cons :agentset list))
+
 (defun agentset-p (o)
  (or
   (eql o :turtles)

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 31d2f31ae4287af0e806e3b5f0a182d4cd11c6aa..c590f2f60a7d5e67faa2dbd885630db507271773 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -49,18 +49,16 @@ DESCRIPTION:
   (:pink 135d0)))
 
 (defun create-turtle ()
- (setf
-  *turtles*
-  (nconc
-   *turtles*
-   (list
-    (make-turtle
-     :who (coerce *current-id* 'double-float)
-     :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
-     :heading (coerce (clnl-random:next-int 360) 'double-float)
-     :xcor 0d0
-     :ycor 0d0))))
- (incf *current-id*))
+ (let
+  ((new-turtle (make-turtle
+                :who (coerce *current-id* 'double-float)
+                :color (coerce (+ 5 (* 10 (clnl-random:next-int 14))) 'double-float)
+                :heading (coerce (clnl-random:next-int 360) 'double-float)
+                :xcor 0d0
+                :ycor 0d0)))
+  (setf *turtles* (nconc *turtles* (list new-turtle)))
+  (incf *current-id*)
+  new-turtle))
 
 (defun die ()
  "DIE => RESULT
@@ -441,12 +439,13 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
  (turn-right (- n)))
 
-(defun create-turtles (n)
- "CREATE-TURTLES N => RESULT
+(defun create-turtles (n &optional fn)
+ "CREATE-TURTLES N &optional FN => RESULT
 
 ARGUMENTS AND VALUES:
 
   N: an integer, the numbers of turtles to create
+  FN: A function, applied to each turtle after creation
   RESULT: undefined
 
 DESCRIPTION:
@@ -454,11 +453,13 @@ DESCRIPTION:
   Creates number new turtles at the origin.
 
   New turtles have random integer headings and the color is randomly selected
-  from the 14 primary colors.  If commands are supplied, the new turtles
-  immediately run them (unimplemented).
+  from the 14 primary colors.  If a function is supplied, the new turtles
+  immediately run it.
 
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles"
- (loop :for i :from 1 :to n :do (create-turtle)))
+ (let
+  ((new-turtles (loop :repeat n :collect (create-turtle))))
+  (when fn (ask (list->agentset new-turtles) fn))))
 
 (defun reset-ticks ()
  "RESET-TICKS => RESULT

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 9c805749c26aaadc76e3d1fa96ebb82393f3c8c2..622723748d606f2d9bcb8565fc1c6c1c72efa543 100644 (file)
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -26,7 +26,6 @@
 (defparameter *dynamic-prims* nil)
 
 (defun prim-name (prim) (getf prim :name))
-(defun prim-num-args (prim) (length (getf prim :args)))
 (defun prim-args (prim) (getf prim :args))
 (defun prim-structure-prim (prim) (getf prim :structure-prim))
 (defun prim-is-infix (prim) (getf prim :infix))
@@ -79,85 +78,110 @@ DESCRIPTION:
   ((*dynamic-prims* dynamic-prims))
   (parse-internal lexed-ast)))
 
-(defun parse-internal (lexed-ast &key prev-item arg-countdown)
+(defun parse-internal (lexed-ast &key prev-item prev-remaining-arg remaining-args)
  (let
   ((prim (and lexed-ast (symbolp (car lexed-ast)) (find-prim (car lexed-ast)))))
   (cond
-   ((and arg-countdown (zerop arg-countdown)) (append (when prev-item (list prev-item)) lexed-ast))
+   ((and remaining-args (eql (car remaining-args) :done-with-args))
+    (append (when prev-item (list (help-arg prev-item prev-remaining-arg))) lexed-ast))
    ((and prim (prim-is-infix prim))
-    (parse-prim prim lexed-ast prev-item arg-countdown)) ; Special casing infix prims is cleaner
+    (parse-prim prim lexed-ast prev-item prev-remaining-arg remaining-args)) ; Special casing infix prims is cleaner
    (t
     (append
-     (when prev-item (list prev-item))
+     (when prev-item (list (help-arg prev-item prev-remaining-arg)))
      (cond
       ((not lexed-ast) nil)
       ((stringp (car lexed-ast))
        (parse-internal (cdr lexed-ast)
         :prev-item (car lexed-ast)
-        :arg-countdown (when arg-countdown (1- arg-countdown))))
+        :prev-remaining-arg (car remaining-args)
+        :remaining-args (cdr remaining-args)))
       ((numberp (car lexed-ast))
        (parse-internal (cdr lexed-ast)
         :prev-item (coerce (car lexed-ast) 'double-float)
-        :arg-countdown (when arg-countdown (1- arg-countdown))))
-      ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) arg-countdown))
+        :prev-remaining-arg (car remaining-args)
+        :remaining-args (cdr remaining-args)))
+      ((eql (intern "(" :keyword) (car lexed-ast)) (parse-parened-expr (cdr lexed-ast) remaining-args))
       ((eql (intern ")" :keyword) (car lexed-ast)) (error "Closing parens has no opening parens"))
-      ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) arg-countdown))
-      ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) arg-countdown))
+      ((eql :let (car lexed-ast)) (parse-let (cdr lexed-ast) remaining-args))
+      ((eql :[ (car lexed-ast)) (parse-block (cdr lexed-ast) remaining-args))
       (prim
        (when (prim-structure-prim prim)
         (error "This doesn't make sense here"))
-       (parse-prim prim lexed-ast nil arg-countdown))
+       (parse-prim prim lexed-ast nil prev-remaining-arg remaining-args))
       (t (error "Couldn't parse ~S" lexed-ast))))))))
 
-(defun parse-let (lexed-ast arg-countdown)
+(defun parse-let (lexed-ast remaining-args)
  (when (not (keywordp (car lexed-ast))) (error "Needed a keyword for let"))
  (let*
-  ((half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown 1)))
+  ((half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (list t :done-with-args))))
   (let
    ((*dynamic-prims* (cons (list :name (car lexed-ast)) *dynamic-prims*)))
    (parse-internal
     (cdr half-parsed-remainder)
-    :arg-countdown (when arg-countdown (1- arg-countdown))
-    :prev-item (list :let (car lexed-ast) (car half-parsed-remainder))))))
+    :remaining-args (cdr remaining-args)
+    :prev-remaining-arg (car remaining-args)
+    :prev-item (list :let (car lexed-ast) (cadr (car half-parsed-remainder)))))))
 
-(defun parse-prim (prim lexed-ast prev-item arg-countdown)
+(defun parse-prim (prim lexed-ast prev-item prev-remaining-arg remaining-args)
  (let*
-  ((num-args (- (prim-num-args prim) (if (prim-is-infix prim) 1 0)))
-   (half-parsed-remainder (parse-internal (cdr lexed-ast) :arg-countdown num-args)))
-  (parse-internal
-   (nthcdr num-args half-parsed-remainder)
-   :arg-countdown (when arg-countdown (if (prim-is-infix prim) arg-countdown (1- arg-countdown)))
-   :prev-item
-   (cons
-    (prim-name prim)
-    (mapcar
-     #'help-arg
-     (prim-args prim)
-     (append
-      (when (prim-is-infix prim) (list prev-item))
-      (butlast half-parsed-remainder (- (length half-parsed-remainder) num-args))))))))
+  ((args (if (prim-is-infix prim) (cdr (prim-args prim)) (prim-args prim)))
+   (half-parsed-remainder (parse-internal (cdr lexed-ast) :remaining-args (append args (list :done-with-args))))
+   (breakpoint (or
+                (position-if (lambda (form) (or (not (listp form)) (not (eql :arg (car form))))) half-parsed-remainder)
+                (length half-parsed-remainder)))
+   (already-parsed-limbo-forms
+    (subseq half-parsed-remainder breakpoint (min (length args) (length half-parsed-remainder))))
+   (middle-forms
+    (cons
+     (cons
+      (prim-name prim)
+      (append
+       (when (prim-is-infix prim) (list (second (help-arg prev-item (car (prim-args prim))))))
+       (mapcar #'cadr (subseq half-parsed-remainder 0 breakpoint))))
+     already-parsed-limbo-forms)))
+  (append
+   (butlast middle-forms)
+   (parse-internal
+    (nthcdr (length args) half-parsed-remainder)
+    :remaining-args (if (prim-is-infix prim) remaining-args (cdr remaining-args))
+    :prev-remaining-arg (if (prim-is-infix prim) prev-remaining-arg (car remaining-args))
+    :prev-item (car (last middle-forms))))))
 
-(defun help-arg (arg-type arg)
+(defun help-arg (arg arg-type)
  (cond
+  ((not arg-type) arg)
   ((eql 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))))
+    (list :arg (cons :command-block (cdr arg)))))
   ((eql arg-type :reporter-block)
    (if (not (and (consp arg) (eql 'block (car arg))))
     (error "Required a block, but found a ~A" arg)
-    (cons :reporter-block (cdr arg))))
-  ((or (eql arg-type :list) (and (listp arg-type) (find :list arg-type)))
-   (if (and (consp arg) (eql 'block (car arg)))
-    (cons :list-literal (cdr arg))
-    arg))
-  (t arg)))
+    (list :arg (cons :reporter-block (cdr arg)))))
+  ((or
+    (eql arg-type :list)
+    (and (listp arg-type) (find :list arg-type)))
+   (list
+    :arg
+    (if (and (consp arg) (eql 'block (car arg)))
+     (cons :list-literal (cdr arg))
+     arg)))
+  ((and
+    (listp arg-type)
+    (find :command-block arg-type)
+    (consp arg)
+    (eql 'block (car arg)))
+   (list :arg (cons :command-block (cdr arg))))
+  ((and (listp arg-type) (find :optional arg-type)) arg)
+  (t (list :arg arg))))
 
-(defun parse-block (tokens arg-countdown)
+(defun parse-block (tokens remaining-args)
  (multiple-value-bind (in-block after-block) (find-closing-bracket tokens)
   (parse-internal after-block
    :prev-item (cons 'block (parse-internal in-block))
-   :arg-countdown (when arg-countdown (1- arg-countdown)))))
+   :prev-remaining-arg (car remaining-args)
+   :remaining-args (cdr remaining-args))))
 
 (defun find-closing-bracket (tokens &optional (depth 0))
  (cond
@@ -168,7 +192,7 @@ DESCRIPTION:
       (find-closing-bracket (cdr tokens) (case (car tokens) (:[ (1+ depth)) (:] (1- depth)) (t depth)))
       (values (cons (car tokens) in-block) after-block)))))
 
-(defun parse-parened-expr (tokens arg-countdown)
+(defun parse-parened-expr (tokens remaining-args)
  (multiple-value-bind (in-block after-block) (find-closing-paren tokens)
   (parse-internal after-block
    :prev-item
@@ -176,7 +200,8 @@ DESCRIPTION:
     ((parsed-in-block (parse-internal in-block)))
     (when (/= 1 (length parsed-in-block)) (error "Expected ) here"))
     (car parsed-in-block))
-   :arg-countdown (when arg-countdown (1- arg-countdown)))))
+   :prev-remaining-arg (car remaining-args)
+   :remaining-args (cdr remaining-args))))
 
 (defun find-closing-paren (tokens &optional (depth 0))
  (cond
@@ -222,7 +247,7 @@ DESCRIPTION:
 (defprim :any? (:agentset))
 (defprim :ask (:agentset :command-block))
 (defprim :clear-all ())
-(defprim :crt (:number))
+(defprim :crt (:number (:command-block :optional)))
 (defprim :color ())
 (defprim :count (:agentset))
 (defprim :die ())

diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp
index 7a362cd77d542a31343f1f9dc7bf537205e252a3..a82c5973a66f33863db11fedfd5bcd9a9a1ff0ea 100644 (file)
--- a/src/test/simpletests.lisp
+++ b/src/test/simpletests.lisp
@@ -15,6 +15,9 @@
 (defsimplecommandtest "Simple crt and fd" "crt 5 ask turtles [ fd 1 ]"
  "BEB43404EDC7852985A9A7FC312481785FE553A0")
 
+(defsimplecommandtest "Simple crt and fd 2" "crt 5 [ fd 1 ]"
+ "BEB43404EDC7852985A9A7FC312481785FE553A0")
+
 (defsimplecommandtest "Wrapping 1" "crt 5 ask turtles [ fd 5 ]"
  "1098A56973DA04E7AEA7659C40E3FF3EC7862B02")
 
@@ -147,7 +150,7 @@
 (defsimplecommandtest "ticks 1" "reset-ticks tick"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
 
-(defreportertestwithsetup "ticks 1" "reset-ticks tick tick" "ticks" "2"
+(defreportertestwithsetup "ticks 2" "reset-ticks tick tick" "ticks" "2"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
 
 (defreportertestwithsetup "of / who 1" "crt 10" "[ who ] of turtles" "[5 9 4 3 7 0 1 2 6 8]"