From bc6386a709da76fef1393a11a7251b4be7032fda Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Fri, 13 May 2016 15:07:47 -0500 Subject: [PATCH] Code - breeds --- bin/runcmd.scala | 21 ++++++++ src/main/code-parse.lisp | 54 +++++++++++++++----- src/main/main.lisp | 104 +++++++++++++++++++-------------------- src/main/nvm/base.lisp | 6 ++- src/main/nvm/nvm.lisp | 53 +++++++++++++------- src/main/package.lisp | 2 +- src/main/parse.lisp | 22 +++++++-- src/main/transpile.lisp | 2 +- src/test/modeltests.lisp | 22 +++++++++ 9 files changed, 196 insertions(+), 90 deletions(-) diff --git a/bin/runcmd.scala b/bin/runcmd.scala index f466887..b91ed4e 100755 --- a/bin/runcmd.scala +++ b/bin/runcmd.scala @@ -63,6 +63,27 @@ ticks @#$#@#$#@ @#$#@#$#@ +default +true +0 +Polygon -7500403 true true 150 5 40 250 150 205 260 250 + +sheep +false +15 +Circle -1 true true 203 65 88 +Circle -1 true true 70 65 162 +Circle -1 true true 150 105 120 +Polygon -7500403 true false 218 120 240 165 255 165 278 120 +Circle -7500403 true false 214 72 67 +Rectangle -1 true true 164 223 179 298 +Polygon -1 true true 45 285 30 285 30 240 15 195 45 210 +Circle -1 true true 3 83 150 +Rectangle -1 true true 65 221 80 296 +Polygon -1 true true 195 285 210 285 210 240 240 210 195 210 +Polygon -7500403 true false 276 85 285 105 302 99 294 83 +Polygon -7500403 true false 219 85 210 105 193 99 201 83 + @#$#@#$#@ NetLogo 5.2.0""") } else { diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index b2a9e45..1cb6662 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -9,18 +9,34 @@ (defvar *dynamic-prims* nil) (defun global->prim (global) - (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*)))) + (list + :name global + :type :reporter + :precedence 10 + :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*)))) (defun own->prim (symb) - (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb)))) + (list :name symb :type :reporter :precedence 10 :macro `(lambda () '(clnl-nvm:agent-value ,symb)))) (defun breed->prims (breed-list) - (let - ((plural-name (symbol-name (car breed-list)))) + (let* + ((plural (car breed-list)) + (singular (cadr breed-list)) + (plural-name (symbol-name plural))) (list - (list :name (car breed-list)) - (list :name (intern (format nil "~A-HERE" plural-name) :keyword)) - (list :name (intern (format nil "CREATE-~A" plural-name) :keyword) :args '(:number :command-block))))) + (list :name plural :type :reporter :precedence 10 :macro `(lambda () ,plural)) + (list + :name (intern (format nil "~A-HERE" plural-name) :keyword) + :type :reporter + :precedence 10 + :macro `(lambda () '(clnl-nvm:turtles-here ,plural))) + (list + :name (intern (format nil "CREATE-~A" plural-name) :keyword) + :type :command + :args '(:number (:command-block :optional)) + :precedence 0 + :macro `(lambda (num &optional command-block) + `(clnl-nvm:create-turtles ,num ,,plural ,command-block)))))) (defun parse (lexed-ast &optional external-globals) "PARSE LEXED-AST &optional EXTERNAL-GLOBALS => AST, PRIMS @@ -67,6 +83,7 @@ DESCRIPTION: (list :name (cadr lexed-ast) :type :command + :precedence 0 :func `(function ,(intern (symbol-name (cadr lexed-ast)) clnl:*model-package*))) (procedures->prims (cddr lexed-ast)))) (t (procedures->prims (cdr lexed-ast))))) @@ -163,9 +180,7 @@ ARGUMENTS AND VALUES: DESCRIPTION: Returns the turtles own variables that get declared in the code." - (mapcar - (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword)) - (cdr (second (find :turtles-own code-parsed-ast :key #'car))))) + (cdr (second (find :turtles-own code-parsed-ast :key #'car)))) (defun patches-own-vars (code-parsed-ast) "PATCHES-OWN-VARS CODE-PARSED-AST => PATCHES-OWN-VARS @@ -180,9 +195,22 @@ ARGUMENTS AND VALUES: DESCRIPTION: Returns the turtles own variables that get declared in the code." - (mapcar - (lambda (patches-own-var) (intern (symbol-name patches-own-var) :keyword)) - (cdr (second (find :patches-own code-parsed-ast :key #'car))))) + (cdr (second (find :patches-own code-parsed-ast :key #'car)))) + +(defun breeds (code-parsed-ast) + "BREEDS CODE-PARSED-AST => BREEDS + + BREEDS: BREED* + +ARGUMENTS AND VALUES: + + CODE-PARSED-AST: An ast as created by clnl-code-parse:parse + BREED: A symbol interned in :keyword + +DESCRIPTION: + + Returns the breeds that get declared in the code." + (mapcar #'cadadr (remove :breed code-parsed-ast :test-not #'equal :key #'car))) (defun procedures (code-parsed-ast) "PROCEDURES CODE-PARSED-AST => PROCEDURES diff --git a/src/main/main.lisp b/src/main/main.lisp index 29c50ea..35a5961 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -83,6 +83,47 @@ DESCRIPTION: stages need to turn them into Common Lisp code, run it, and return the RESULT." (eval (clnl-transpiler:transpile (clnl-parser:parse (clnl-lexer:lex reporter))))) +; Because prims are used both at generation time and later at runtime, certain things in +; them must be escaped a little bit more, such as wrapping the whole thing in a list +; primitive. This way, the output of these things looks like halfway decent lisp, +; and everything works nicely. We don't want any showing up or anything +(defun munge-prim (prim) + (let + ((copied (copy-list prim))) + (when (getf copied :args) (setf (getf copied :args) `(quote ,(getf copied :args)))) + `(list ,@copied))) + +(defun netlogo-callback-body (prims) + `(eval + (clnl-transpiler:transpile + (clnl-parser:parse + (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*)) + (list ,@(mapcar #'munge-prim prims))) + (list ,@(mapcar #'munge-prim prims))))) + +(defun create-world-call (model globals code-ast) + `(clnl-nvm:create-world + :dims ',(clnl-model:world-dimensions model) + :globals (list + ,@(mapcar + (lambda (pair) + `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) + globals)) + :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) + :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast) + :breeds ',(clnl-code-parser:breeds code-ast))) + +(defun create-proc-body (proc prims) + `(,(intern (string-upcase (car proc)) *model-package*) () + ,@(cdr ; remove the progn, cuz it looks nicer + (clnl-transpiler:transpile (cadr proc) + (mapcar + (lambda (prim) + (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in + ; this scope while preserving them for the generational purposes below + (append (list :macro (eval (getf prim :macro))) prim) + prim)) prims))))) + (defun model->single-form-lisp (model &key (seed 15) initialize-interface netlogo-callback) (multiple-value-bind (code-ast prims) @@ -94,43 +135,23 @@ DESCRIPTION: (clnl-code-parser:globals code-ast)))) `(prog () ; First declare is in case we don't use it, it shows up in export correctly - (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))) + ,@(when (and (> (length globals) 0) netlogo-callback) + `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))))) (let ,(mapcar (lambda (pair) (list (intern (string-upcase (car pair)) *model-package*) (cadr pair))) globals) ; We declare twice rather than once and doing a bunch of setfs - (declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))) + ,@(when (and (> (length globals) 0) netlogo-callback) + `((declare (special ,@(mapcar (lambda (pair) (intern (string-upcase (car pair)) *model-package*)) globals))))) (labels ,(mapcar - (lambda (proc) - `(,(intern (string-upcase (car proc)) *model-package*) () - ,@(cdr ; remove the progn, cuz it looks nicer - (clnl-transpiler:transpile (cadr proc) - (mapcar - (lambda (prim) - (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in - ; this scope while preserving them for the generational purposes below - (append (list :macro (eval (getf prim :macro))) prim) - prim)) prims))))) + (lambda (proc) (create-proc-body proc prims)) (clnl-code-parser:procedures code-ast)) (clnl-random:set-seed ,seed) - (clnl-nvm:create-world - :dims ',(clnl-model:world-dimensions model) - :globals (list - ,@(mapcar - (lambda (pair) - `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) - globals)) - :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) - :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)) + ,(create-world-call model globals code-ast) ,@(when netlogo-callback `((funcall ,netlogo-callback - (lambda (netlogo-code) - (eval - (clnl-transpiler:transpile - (clnl-parser:parse - (clnl-lexer:lex netlogo-code) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims)))))))) + (lambda (,(intern "NETLOGO-CODE" *model-package*)) + ,(netlogo-callback-body prims))))) ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model)))))))))) (setf (documentation 'model->single-form-lisp 'function) @@ -175,36 +196,15 @@ DESCRIPTION: `(defvar ,(intern (string-upcase (car pair)) *model-package*) ,(cadr pair))) globals) ,@(mapcar - (lambda (proc) - `(defun ,(intern (string-upcase (car proc)) *model-package*) () - ,@(cdr ; remove the progn, cuz it looks nicer - (clnl-transpiler:transpile (cadr proc) - (mapcar - (lambda (prim) - (if (getf prim :macro) ; The reason we do this is because with macros, we want to evaluate them in - ; this scope while preserving them for the generational purposes below - (append (list :macro (eval (getf prim :macro))) prim) - prim)) prims))))) + (lambda (proc) `(defun ,@(create-proc-body proc prims))) (clnl-code-parser:procedures code-ast)) (defun ,boot-fn () (clnl-random:set-seed ,seed) - (clnl-nvm:create-world - :dims ',(clnl-model:world-dimensions model) - :globals (list - ,@(mapcar - (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) - globals)) - :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) - :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)) + ,(create-world-call model globals code-ast) ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))) ,@(when netlogo-callback-fn `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*)) - (eval - (clnl-transpiler:transpile - (clnl-parser:parse - (clnl-lexer:lex ,(intern "NETLOGO-CODE" *model-package*)) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))) - (list ,@(mapcar (lambda (prim) `(list ,@prim)) prims))))))))))) + ,(netlogo-callback-body prims)))))))) (setf (documentation 'model->multi-form-lisp 'function) "MODEL->MULTI-FORM-LISP MODEL BOOT-FN &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK-FN => FORMS diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 294715a..063dfb5 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -31,7 +31,7 @@ DESCRIPTION: :stop is returned." `(handler-case (progn ,@forms) (stop (s) (declare (ignore s)) :stop))) -(defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) +(defstruct turtle who breed color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) (defstruct patch color xcor ycor own-vars turtles) (defun agentset-list (agentset) @@ -39,12 +39,15 @@ DESCRIPTION: ((eql agentset :turtles) *turtles*) ((eql agentset :patches) *patches*) ((and (listp agentset) (eql :agentset (car agentset))) (cddr agentset)) + ((find agentset *breeds* :key #'car) + (remove agentset *turtles* :key #'turtle-breed :test-not #'eql)) (t (error "Doesn't seem to be an agentset: ~A" agentset)))) (defun agentset-breed (agentset) (cond ((eql agentset :turtles) :turtles) ((eql agentset :patches) :patches) + ((find agentset *breeds* :key #'car) agentset) ((and (listp agentset) (eql :agentset (car agentset))) (second agentset)) (t (error "Doesn't seem to be an agentset: ~A" agentset)))) @@ -55,6 +58,7 @@ DESCRIPTION: (or (eql o :turtles) (eql o :patches) + (find o *breeds* :key #'car) (and (listp o) (eql :agentset (car o))))) (defun agent-p (o) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index bcf4be1..0981332 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -48,9 +48,10 @@ DESCRIPTION: (:magenta 125d0) (:pink 135d0))) -(defun create-turtle (&optional base-turtle) - (let - ((new-turtle (make-turtle +(defun create-turtle (breed &optional base-turtle) + (let* + ((breed (or breed (and base-turtle (turtle-breed base-turtle)) :turtles)) + (new-turtle (make-turtle :who (coerce *current-id* 'double-float) :color (if base-turtle (turtle-color base-turtle) @@ -58,7 +59,8 @@ DESCRIPTION: :heading (if base-turtle (turtle-heading base-turtle) (coerce (clnl-random:next-int 360) 'double-float)) - :shape (breed-default-shape :turtles) + :breed breed + :shape (breed-default-shape breed) :xcor (if base-turtle (turtle-xcor base-turtle) 0d0) :ycor (if base-turtle (turtle-ycor base-turtle) 0d0)))) (let @@ -125,7 +127,7 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles" :turtles) -(defun turtles-here () +(defun turtles-here (&optional breed) "TURTLES-HERE => TURTLES ARGUMENTS AND VALUES: @@ -139,7 +141,11 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#turtles-here" (when (not (turtle-p *self*)) (error "Gotta call turtles-here with a turtle")) - (list->agentset (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))) :turtles)) + (let + ((patch-turtles (patch-turtles (patch-at (turtle-xcor *self*) (turtle-ycor *self*))))) + (list->agentset + (if breed (remove breed patch-turtles :key #'turtle-breed :test-not #'eql) patch-turtles) + (or breed :turtles)))) (defun ask (agent-or-agentset fn) "ASK AGENT-OR-AGENTSET FN => RESULT @@ -555,26 +561,28 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#right" (turn-right (- n))) -(defun create-turtles (n &optional fn) - "CREATE-TURTLES N &optional FN => RESULT +(defun create-turtles (n &optional breed fn) + "CREATE-TURTLES N &optional BREED FN => RESULT ARGUMENTS AND VALUES: N: an integer, the numbers of turtles to create + BREED: a breed FN: A function, applied to each turtle after creation RESULT: undefined DESCRIPTION: - Creates number new turtles at the origin. + Creates N new turtles at the origin. New turtles have random integer headings and the color is randomly selected - from the 14 primary colors. If a function is supplied, the new turtles - immediately run it. + from the 14 primary colors. If FN is supplied, the new turtles immediately + run it. If a BREED is supplied, that is the breed the new turtles are set + to. See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#create-turtles" (let - ((new-turtles (loop :repeat n :collect (create-turtle)))) + ((new-turtles (loop :repeat n :collect (create-turtle breed)))) (when fn (ask (list->agentset new-turtles :turtles) fn)))) (defun hatch (n &optional fn) @@ -596,7 +604,7 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#hatch" (when (not (turtle-p *self*)) (error "Can only hatch from turtle scope")) (let - ((new-turtles (loop :repeat n :collect (create-turtle *self*)))) + ((new-turtles (loop :repeat n :collect (create-turtle nil *self*)))) (when fn (ask (list->agentset new-turtles :turtles) fn)))) (defun reset-ticks () @@ -667,13 +675,14 @@ DESCRIPTION: (defun clear-ticks () (setf *ticks* nil)) -(defun create-world (&key dims globals turtles-own-vars patches-own-vars) - "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS => RESULT +(defun create-world (&key dims globals turtles-own-vars patches-own-vars breeds) + "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS BREEDS => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX) GLOBALS: GLOBAL* TURTLES-OWN-VARS: TURTLES-OWN-VAR* PATCHES-OWN-VARS: PATCHES-OWN-VAR* + BREEDS: BREED* GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: @@ -685,6 +694,7 @@ ARGUMENTS AND VALUES: YMAX: An integer representing the maximum patch coord in Y TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package PATCHES-OWN-VAR: Symbol for the patches own variable in the keyword package + BREED: A list of symbols representing the possible preeds GLOBAL-NAME: Symbol for the global in the keyword package GLOBAL-ACCESS-FUNC: Function to get the value of the global @@ -698,7 +708,10 @@ DESCRIPTION: (setf *patches-own-vars* patches-own-vars) (setf *dimensions* dims) (setf *globals* globals) - (setf *breeds* (list (list :turtles "default"))) + (setf *breeds* + (append + (list (list :turtles "default")) + (mapcar (lambda (breed) (list breed "default")) breeds))) (clear-ticks) (clear-patches) (clear-turtles)) @@ -730,6 +743,11 @@ DESCRIPTION: (defmethod dump-object ((o turtle)) (format nil "(turtle ~A)" (dump-object (turtle-who o)))) (defmethod dump-object ((o (eql :nobody))) (format nil "nobody")) +(defmethod dump-object ((o (eql :turtles))) (format nil "{all-turtles}")) +(defmethod dump-object ((o symbol)) + (cond + ((find o *breeds* :key #'car) (format nil "{breed ~(~A~)}" o)) + (t (error "Keyword unrecognized by dump object: ~A" o)))) (defun current-state () "CURRENT-STATE => WORLD-STATE @@ -779,7 +797,7 @@ DESCRIPTION: (mapcar (lambda (turtle) (format nil - "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A~{,\"~A\"~}" + "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"false\",\"~A\",~A~{,\"~A\"~}" (dump-object (turtle-who turtle)) (dump-object (turtle-color turtle)) (dump-object (turtle-heading turtle)) @@ -788,6 +806,7 @@ DESCRIPTION: (dump-object (turtle-shape turtle)) (dump-object (turtle-label turtle)) (dump-object (turtle-label-color turtle)) + (dump-object (turtle-breed turtle)) (dump-object (turtle-size turtle)) "\"1\",\"\"\"up\"\"\"" (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*)))) diff --git a/src/main/package.lisp b/src/main/package.lisp index ac81d3f..6db65fb 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -19,7 +19,7 @@ into an ast that can be transpiled later.")) (defpackage #:clnl-code-parser (:use :common-lisp) - (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars) + (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars #:breeds) (:documentation "CLNL Code Parser diff --git a/src/main/parse.lisp b/src/main/parse.lisp index a44caea..e3daa08 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -26,6 +26,7 @@ (defparameter *dynamic-prims* nil) (defun prim-name (prim) (getf prim :name)) +(defun prim-precedence (prim) (getf prim :precedence)) (defun prim-args (prim) (getf prim :args)) (defun prim-structure-prim (prim) (getf prim :structure-prim)) (defun prim-is-infix (prim) (getf prim :infix)) @@ -41,7 +42,7 @@ "PARSE LEXED-AST &optional DYNAMIC-PRIMS => AST DYNAMIC-PRIMS: DYNAMIC-PRIM* - DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX) + DYNAMIC-PRIM: (:name NAME :args ARGS :infix INFIX :precedence PRECEDENCE) ARGS: ARG* ARGUMENTS AND VALUES: @@ -49,7 +50,8 @@ ARGUMENTS AND VALUES: LEXED-AST: An ambigious ast AST: An unambigious ast that can be transpiled NAME: A symbol in the keyword package - INFIX: Boolean denoting whether the prim is infix + INFIX: Boolean denoting whether the prim is infix, defaulting to NIL + PRECEDENCE: A number, usually 10 for reporters, and 0 for commands ARG: A list of symbols denoting the type of argument DESCRIPTION: @@ -58,7 +60,12 @@ DESCRIPTION: DYNAMIC-PRIMS that are passed in are used to avoid compilation errors on things not statically defined by the NetLogo language, be they user defined - procedures or generated primitives from breed declarations. + procedures or generated primitives from breed declarations. NAME and PRECEDENCE + are required for all dynamic prims. + + PRECEDENCE is a number used to calculate the order of operations. Higher numbers + have more precedence than lower ones. Generally all commands should have the + lowest precedence, and all reporters should have 10 as the precedence. The possible values for ARG are :agentset, :boolean, :number, :command-block, or t for wildcard. @@ -72,6 +79,10 @@ DESCRIPTION: Examples are too numerous and varied, but by inserting an output between the lexer and this code, a good idea of what goes on can be gotten." + (when (find nil dynamic-prims :key #'prim-name) + (error "All passed in prims must have a name: ~S" (find nil dynamic-prims :key #'prim-name))) + (when (find nil dynamic-prims :key #'prim-precedence) + (error "All passed in prims must have a precedence: ~S" (find nil dynamic-prims :key #'prim-precedence))) (let ; could have defined this using the special variable, but didn't to make the ; function definition simpler, as well as the documentation. @@ -141,10 +152,10 @@ DESCRIPTION: (< 1 (length prev-item)) (keywordp (car x)) (find-prim (car x)) - (getf (find-prim (car x)) :precedence)) + (prim-precedence (find-prim (car x)))) 20))) (cond - ((<= (getf prim :precedence) (calculate-precedence prev-item)) + ((<= (prim-precedence prim) (calculate-precedence prev-item)) (cons (prim-name prim) (cons @@ -285,6 +296,7 @@ DESCRIPTION: (defprim :ca () 0) (defprim :clear-all () 0) (defprim :crt (:number (:command-block :optional)) 0) +(defprim :create-turtles (:number (:command-block :optional)) 0) (defprim :color () 10) (defprim :count (:agentset) 10) (defprim :die () 0) diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index b140653..91af23a 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -188,7 +188,7 @@ DESCRIPTION: (defagentvalueprim :color) (defsimpleprim '(:clear-all :ca) :command clnl-nvm:clear-all) (defsimpleprim :count :reporter clnl-nvm:count) -(defsimpleprim :crt :command clnl-nvm:create-turtles) +(defprim '(:crt :create-turtles) :command (lambda (num &optional fn) `(clnl-nvm:create-turtles ,num nil ,fn))) (defsimpleprim :die :command clnl-nvm:die) (defsimpleprim :display :command clnl-nvm:display) (defsimpleprim :fd :command clnl-nvm:forward) diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index aa9b22b..79ebc4b 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -86,3 +86,25 @@ to go end" "setup go" "2972B3EC1285BDA17656401001E1AE667FA7F5AF") + +(defmodelcommandtest "breeds 1" + "breed [wolves wolf] + +to setup + create-turtles 50 + create-turtles 50 [ fd 1 ] + create-wolves 50 + set-default-shape wolves \"sheep\" + create-wolves 50 [ fd 1 ] +end + +to go + ask turtles [ fd 1 ] + ask wolves [ fd 1 ] + ask turtles [ if 1 < count turtles-here [ fd 1 ] ] + ask wolves [ if 1 < count turtles-here [ fd 1 ] ] + ask turtles [ if 1 < count wolves-here [ fd 1 ] ] + ask wolves [ if 1 < count wolves-here [ fd 1 ] ] +end" + "setup go" + "2614B99F64ACFA2BD64D66B129C0A17F2150FADD") -- 2.25.1