Prims - Implement clear-all, ca

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 3c7c6d6974a85201d8067f48b75a3775927383cf..c98616aeeddcfb53a4cfcdb82abfaa1a0b70b178 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -172,6 +172,22 @@ DESCRIPTION:
   See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#count"
  (coerce (length (agentset-list agentset)) 'double-float))
 
+(defun clear-all ()
+ "CLEAR-ALL => RESULT
+
+ARGUMENTS AND VALUES:
+
+  RESULT: undefined
+
+DESCRIPTION:
+
+  Clears ticks, turtles, patches, globals (unimplemented).
+
+  See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#clear-all"
+ (clear-turtles)
+ (clear-patches)
+ (clear-ticks))
+
 (defun of (fn agent-or-agentset)
  "OF FN AGENT-OR-AGENTSET => RESULT
 
@@ -581,6 +597,25 @@ DESCRIPTION:
  (when (not *ticks*) (error "reset-ticks must be called"))
  *ticks*)
 
+(defun clear-patches ()
+ (setf
+  *patches*
+  (loop
+   :for y :from (max-pycor) :downto (min-pycor)
+   :append (loop
+            :for x :from (min-pxcor) :to (max-pxcor)
+            :collect (make-patch
+                      :xcor (coerce x 'double-float)
+                      :ycor (coerce y 'double-float)
+                      :color 0d0)))))
+
+(defun clear-turtles ()
+ (setf *turtles* nil)
+ (setf *current-id* 0))
+
+(defun clear-ticks ()
+ (setf *ticks* nil))
+
 (defun create-world (&key dims)
  "CREATE-WORLD &key DIMS => RESULT
 
@@ -602,18 +637,9 @@ DESCRIPTION:
   called when an engine is already running, it may do somethign weird."
  (setf *dimensions* dims)
  (setf *breeds* (list (list :turtles "default")))
- (setf
-  *patches*
-  (loop
-   :for y :from (max-pycor) :downto (min-pycor)
-   :append (loop
-            :for x :from (min-pxcor) :to (max-pxcor)
-            :collect (make-patch
-                      :xcor (coerce x 'double-float)
-                      :ycor (coerce y 'double-float)
-                      :color 0d0))))
- (setf *turtles* nil)
- (setf *current-id* 0))
+ (clear-ticks)
+ (clear-patches)
+ (clear-turtles))
 
 ; These match netlogo's dump
 (defgeneric dump-object (o))

diff --git a/src/main/package.lisp b/src/main/package.lisp
index b1c4a2757dfabff275c9a4621502103b43b68e76..f1f53923a9c4865b35afcae127a4a9d30f967ee8 100644 (file)
--- a/src/main/package.lisp
+++ b/src/main/package.lisp
@@ -69,6 +69,7 @@ into an ast that can be transpiled later."))
   ; API as used by transpiled NetLogo programs
   #:agent-value
   #:ask
+  #:clear-all
   #:count
   #:create-turtles
   #:die

diff --git a/src/main/parse.lisp b/src/main/parse.lisp
index 957d177b54792e5a833f371a581b2a7d2c4ca26c..914e0dcbc40770a7e22cd8a3594cdba1458e6e54 100644 (file)
--- a/src/main/parse.lisp
+++ b/src/main/parse.lisp
@@ -246,6 +246,7 @@ DESCRIPTION:
 (defprim :<= (:number :number) :infix)
 (defprim :any? (:agentset))
 (defprim :ask (:agentset :command-block))
+(defprim :ca ())
 (defprim :clear-all ())
 (defprim :crt (:number (:command-block :optional)))
 (defprim :color ())

diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index c2a2087e9460699fe65e4b73f0b13ca170452df7..554e0cdbd07fb348c72825bc411a1ff595449d1f 100644 (file)
--- a/src/main/transpile.lisp
+++ b/src/main/transpile.lisp
@@ -13,9 +13,9 @@
 
 (defun find-prim (symb)
  (when symb
-  (or
-   (find symb *prims* :key #'prim-name)
-   (find-prim (getf (find symb *prim-aliases* :key #'prim-name) :real-symb)))))
+  (find-if
+   (lambda (prim-name) (or (eql symb prim-name) (and (listp prim-name) (find symb prim-name))))
+   *prims* :key #'prim-name)))
 
 ; Let this grow, slowly but surely, eventually taking on calling context, etc.
 ; For now, it's just a
@@ -143,18 +143,19 @@ DESCRIPTION:
 (defprim :any? :reporter (lambda (agentset) `(> (clnl-nvm:count ,agentset) 0)))
 (defsimpleprim :ask :command clnl-nvm:ask)
 (defagentvalueprim :color)
+(defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all)
 (defsimpleprim :count :reporter clnl-nvm:count)
 (defsimpleprim :crt :command clnl-nvm:create-turtles)
 (defsimpleprim :die :command clnl-nvm:die)
 (defsimpleprim :fd :command clnl-nvm:forward)
 (defsimpleprim :hatch :command clnl-nvm:hatch)
 (defprim :if :command (lambda (pred a) `(when ,pred ,@(make-command-block-inline a))))
-(defprim :ifelse :command (lambda (pred a b)
-                           `(if ,pred
-                             ,@(make-command-block-inline a)
-                             ,@(make-command-block-inline b))))
+(defprim '(:ifelse :if-else)
+ :command (lambda (pred a b)
+           `(if ,pred
+             ,@(make-command-block-inline a)
+             ,@(make-command-block-inline b))))
 
-(defprim-alias :if-else :ifelse)
 (defagentvalueprim :label)
 (defagentvalueprim :label-color)
 (defsimpleprim :lt :command clnl-nvm:turn-left)

diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp
index f4ac4f96234459ad7c5000ef9f35d46648bab35a..d85675db12428ec64b7a8d8c0ad0d20604f4b9a7 100644 (file)
--- a/src/test/simpletests.lisp
+++ b/src/test/simpletests.lisp
@@ -250,3 +250,6 @@
 
 (defsimplereportertest "round 3" "round 2.5" "3"
  "E1DE30F072D785E0D0B59F28B0F7853E3D3E0D8B")
+
+(defsimplecommandtest "clear-all 1" "crt 10 ask patches [ set pcolor random 100 ] clear-all"
+ "7B5DF28923D7FD72158018A876DE8ED02CFB0882")