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))))
 
   ((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)
 (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 ()
   (: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
 
 (defun die ()
  "DIE => RESULT


@@ -441,12 +439,13 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right"
  (turn-right (- n)))
 
   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
 
 ARGUMENTS AND VALUES:
 
   N: an integer, the numbers of turtles to create

+  FN: A function, applied to each turtle after creation

   RESULT: undefined
 
 DESCRIPTION:
   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
   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"
 
   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
 
 (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))
 (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))
 (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)))
 
   ((*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
  (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))
    ((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
    (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)
      (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)
       ((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 (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"))
       (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))))))))
 
       (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*
  (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)
   (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*
  (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
  (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)
   ((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)
   ((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))
  (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
 
 (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)))))
 
       (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
  (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))
     ((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
 
 (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 :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 ())
 (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" "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")
 
 (defsimplecommandtest "Wrapping 1" "crt 5 ask turtles [ fd 5 ]"
  "1098A56973DA04E7AEA7659C40E3FF3EC7862B02")
 


@@ -147,7 +150,7 @@
 (defsimplecommandtest "ticks 1" "reset-ticks tick"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
 
 (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]"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
 
 (defreportertestwithsetup "of / who 1" "crt 10" "[ who ] of turtles" "[5 9 4 3 7 0 1 2 6 8]"