From 97c390f3cee5094fa6795acd4b25b7598d5dd1bd Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Mon, 9 May 2016 07:58:22 -0500 Subject: [PATCH] Code - turtles-own --- src/main/code-parse.lisp | 37 ++++++++++++++++++++++++++++++++----- src/main/main.lisp | 6 ++++-- src/main/nvm/agent.lisp | 12 +++++++++++- src/main/nvm/base.lisp | 3 ++- src/main/nvm/nvm.lisp | 23 ++++++++++++++--------- src/main/package.lisp | 2 +- src/test/modeltests.lisp | 25 +++++++++++++++++++++++++ 7 files changed, 89 insertions(+), 19 deletions(-) diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index d1b30ee..d40f7ba 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -11,6 +11,9 @@ (defun global->prim (global) (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*)))) +(defun turtles-own->prim (symb) + (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb)))) + (defun breed->prims (breed-list) (let ((plural-name (symbol-name (car breed-list)))) @@ -102,7 +105,14 @@ DESCRIPTION: (cons (list (car lexed-ast) (cons :list-literal in-list)) (let - ((*dynamic-prims* (append (mapcar #'global->prim in-list) *dynamic-prims*))) + ((*dynamic-prims* + (append + (mapcar + (case (car lexed-ast) + (:globals #'global->prim) + (:turtles-own #'turtles-own->prim) + (t #'global->prim)) + in-list) *dynamic-prims*))) (parse-internal after-list))))) (defun parse-breed (lexed-ast) @@ -123,13 +133,13 @@ DESCRIPTION: (values (cons (car tokens) in-block) after-block))))) (defun globals (code-parsed-ast) - "GLOBALS MODEL => GLOBALS + "GLOBALS CODE-PARSED-AST => GLOBALS GLOBALS: GLOBAL* ARGUMENTS AND VALUES: - MODEL: An ast as created by clnl-code-parse:parse + CODE-PARSED-AST: An ast as created by clnl-code-parse:parse GLOBAL: A symbol interned in :keyword DESCRIPTION: @@ -139,15 +149,32 @@ DESCRIPTION: (lambda (global) (list (intern (symbol-name global) :keyword) 0d0)) (cdr (second (find :globals code-parsed-ast :key #'car))))) +(defun turtles-own-vars (code-parsed-ast) + "TURTLES-OWN-VARS CODE-PARSED-AST => TURTLES-OWN-VARS + + TURTLES-OWN-VARS: TURTLES-OWN-VAR* + +ARGUMENTS AND VALUES: + + CODE-PARSED-AST: An ast as created by clnl-code-parse:parse + TURTLES-OWN-VAR: A symbol interned in :keyword + +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))))) + (defun procedures (code-parsed-ast) - "PROCEDURES MODEL => PROCEDURES + "PROCEDURES CODE-PARSED-AST => PROCEDURES PROCEDURES: PROCEDURE* PROCEDURE: (NAME BODY) ARGUMENTS AND VALUES: - MODEL: An ast as created by clnl-code-parse:parse + CODE-PARSED-AST: An ast as created by clnl-code-parse:parse NAME: A symbol interned in :keyword BODY: A list of lexed forms diff --git a/src/main/main.lisp b/src/main/main.lisp index 9862515..6f319c4 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -119,7 +119,8 @@ DESCRIPTION: ,@(mapcar (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) - globals))) + globals)) + :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast)) ,@(when netlogo-callback `((funcall ,netlogo-callback (lambda (netlogo-code) @@ -191,7 +192,8 @@ DESCRIPTION: :globals (list ,@(mapcar (lambda (pair) `(list ,(car pair) (lambda () ,(intern (string-upcase (car pair)) *model-package*)))) - globals))) + globals)) + :turtles-own-vars ',(clnl-code-parser:turtles-own-vars 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*)) diff --git a/src/main/nvm/agent.lisp b/src/main/nvm/agent.lisp index e26186e..ee1d971 100644 --- a/src/main/nvm/agent.lisp +++ b/src/main/nvm/agent.lisp @@ -36,7 +36,7 @@ DESCRIPTION: (defmethod set-agent-value-inner ((,agent ,type) (,var (eql ,symb)) ,new-val) (setf (,accessor ,agent) ,new-val))))) ; Don't want the setter for :who -(defmethod agent-value-inner ((agent turtle) (var (eql :who))) (turtle-who agent)) +(defmethod agent-value-inner ((turtle turtle) (var (eql :who))) (turtle-who turtle)) (defagent-value patch :pcolor patch-color) @@ -44,3 +44,13 @@ DESCRIPTION: (defagent-value turtle :label) (defagent-value turtle :label-color) (defagent-value turtle :size) + +(defmethod agent-value-inner ((turtle turtle) var) + (when (not (find var *turtles-own-vars*)) (error "~S is not a turtle variable" var)) + (or (getf (turtle-own-vars turtle) var) 0d0)) + +(defmethod set-agent-value-inner ((turtle turtle) var new-val) + (when (not (find var *turtles-own-vars*)) (error "~S is not a turtle variable" var)) + (if (getf (turtle-own-vars turtle) var) + (setf (getf (turtle-own-vars turtle) var) new-val) + (setf (turtle-own-vars turtle) (append (list var new-val) (turtle-own-vars turtle))))) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index af87bc2..54d0246 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -3,6 +3,7 @@ (defvar *current-id* 0) (defvar *turtles* nil) +(defvar *turtles-own-vars* nil) (defvar *patches* nil) (defvar *myself* nil) (defvar *self* nil) @@ -29,7 +30,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) +(defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0) shape own-vars) (defstruct patch color xcor ycor) (defun agentset-list (agentset) diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index 766df53..dcba151 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -647,12 +647,13 @@ DESCRIPTION: (defun clear-ticks () (setf *ticks* nil)) -(defun create-world (&key dims globals) - "CREATE-WORLD &key DIMS GLOBALS => RESULT +(defun create-world (&key dims globals turtles-own-vars) + "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX) GLOBALS: GLOBAL* - GLOBAL: (NAME ACCESS-FUNC) + TURTLES-OWN-VARS: TURTLES-OWN-VAR* + GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: @@ -661,8 +662,9 @@ ARGUMENTS AND VALUES: XMAX: An integer representing the maximum patch coord in X YMIN: An integer representing the minimum patch coord in Y YMAX: An integer representing the maximum patch coord in Y - NAME: Symbol for the global in the keyword package - ACCESS-FUNC: Function to get the value of the global + TURTLES-OWN-VAR: Symbol for the turtles own variable in the keyword package + GLOBAL-NAME: Symbol for the global in the keyword package + GLOBAL-ACCESS-FUNC: Function to get the value of the global DESCRIPTION: @@ -670,6 +672,7 @@ DESCRIPTION: This should be called before using the engine in any real capacity. If called when an engine is already running, it may do somethign weird." + (setf *turtles-own-vars* turtles-own-vars) (setf *dimensions* dims) (setf *globals* globals) (setf *breeds* (list (list :turtles "default"))) @@ -746,13 +749,14 @@ DESCRIPTION: (append (list "\"TURTLES\"" - (format nil "~A~A" + (format nil "~A~A~{,\"~A\"~}" "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\"," - "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")) + "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"" + (mapcar #'string-downcase *turtles-own-vars*))) (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\",\"{all-turtles}\",\"false\",\"~A\",~A~{,\"~A\"~}" (dump-object (turtle-who turtle)) (dump-object (turtle-color turtle)) (dump-object (turtle-heading turtle)) @@ -762,7 +766,8 @@ DESCRIPTION: (dump-object (turtle-label turtle)) (dump-object (turtle-label-color turtle)) (dump-object (turtle-size turtle)) - "\"1\",\"\"\"up\"\"\"")) + "\"1\",\"\"\"up\"\"\"" + (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner turtle var)) *turtles-own-vars*)))) *turtles*))) (defun export-patches () diff --git a/src/main/package.lisp b/src/main/package.lisp index 675a70b..38d7ca0 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) + (:export #:parse #:globals #:procedures #:turtles-own-vars) (:documentation "CLNL Code Parser diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index 071aa09..6202c51 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -36,3 +36,28 @@ to go end" "go" "46C620AB8995266C4A2094C461BE197BBACEB8C3") + +(defmodelcommandtest "turtles-own 1" + "turtles-own [a b] +to setup + crt 10 [ + set a 2 + ] +end" + "setup" + "482947557971AC2A66CB35AA5D6850A489C45215") + +(defmodelcommandtest "turtles-own 2" + "turtles-own [a b] +to setup + crt 10 [ + set a 2 + set b a + 1 + ] +end + +to go + ask turtles [ fd b ] +end" + "setup go" + "F8A2BFD71A8A064C37DDB744217AB07CDB0686EB") -- 2.25.1