From: Frank Duncan Date: Mon, 9 May 2016 20:17:18 +0000 (-0500) Subject: Code - patches-own X-Git-Tag: v0.1.0~16 X-Git-Url: https://code.consxy.com/gitweb/?a=commitdiff_plain;h=31f7cb69edd16f175430851d696b1036b07b60f1;p=clnl Code - patches-own --- diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp index d40f7ba..b2a9e45 100644 --- a/src/main/code-parse.lisp +++ b/src/main/code-parse.lisp @@ -11,7 +11,7 @@ (defun global->prim (global) (list :name global :type :reporter :macro `(lambda () ',(intern (symbol-name global) clnl:*model-package*)))) -(defun turtles-own->prim (symb) +(defun own->prim (symb) (list :name symb :type :reporter :macro `(lambda () '(clnl-nvm:agent-value ,symb)))) (defun breed->prims (breed-list) @@ -110,7 +110,8 @@ DESCRIPTION: (mapcar (case (car lexed-ast) (:globals #'global->prim) - (:turtles-own #'turtles-own->prim) + (:turtles-own #'own->prim) + (:patches-own #'own->prim) (t #'global->prim)) in-list) *dynamic-prims*))) (parse-internal after-list))))) @@ -166,6 +167,23 @@ DESCRIPTION: (lambda (turtles-own-var) (intern (symbol-name turtles-own-var) :keyword)) (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 + + PATCHES-OWN-VARS: PATCHES-OWN-VAR* + +ARGUMENTS AND VALUES: + + CODE-PARSED-AST: An ast as created by clnl-code-parse:parse + PATCHES-OWN-VAR: A symbol interned in :keyword + +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))))) + (defun procedures (code-parsed-ast) "PROCEDURES CODE-PARSED-AST => PROCEDURES diff --git a/src/main/main.lisp b/src/main/main.lisp index 6f319c4..29c50ea 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -120,7 +120,8 @@ DESCRIPTION: (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)) + :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) + :patches-own-vars ',(clnl-code-parser:patches-own-vars code-ast)) ,@(when netlogo-callback `((funcall ,netlogo-callback (lambda (netlogo-code) @@ -193,7 +194,8 @@ DESCRIPTION: ,@(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)) + :turtles-own-vars ',(clnl-code-parser:turtles-own-vars code-ast) + :patches-own-vars ',(clnl-code-parser:patches-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 ee1d971..8e97ea0 100644 --- a/src/main/nvm/agent.lisp +++ b/src/main/nvm/agent.lisp @@ -54,3 +54,13 @@ DESCRIPTION: (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))))) + +(defmethod agent-value-inner ((patch patch) var) + (when (not (find var *patches-own-vars*)) (error "~S is not a patch variable" var)) + (or (getf (patch-own-vars patch) var) 0d0)) + +(defmethod set-agent-value-inner ((patch patch) var new-val) + (when (not (find var *patches-own-vars*)) (error "~S is not a patch variable" var)) + (if (getf (patch-own-vars patch) var) + (setf (getf (patch-own-vars patch) var) new-val) + (setf (patch-own-vars patch) (append (list var new-val) (patch-own-vars patch))))) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp index 54d0246..945c5e8 100644 --- a/src/main/nvm/base.lisp +++ b/src/main/nvm/base.lisp @@ -4,6 +4,7 @@ (defvar *turtles* nil) (defvar *turtles-own-vars* nil) +(defvar *patches-own-vars* nil) (defvar *patches* nil) (defvar *myself* nil) (defvar *self* nil) @@ -31,7 +32,7 @@ DESCRIPTION: `(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 patch color xcor ycor) +(defstruct patch color xcor ycor own-vars) (defun agentset-list (agentset) (cond diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index dcba151..42a269a 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 turtles-own-vars) - "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS => RESULT +(defun create-world (&key dims globals turtles-own-vars patches-own-vars) + "CREATE-WORLD &key DIMS GLOBALS TURTLES-OWN-VARS PATCHES-OWN-VARS => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX) GLOBALS: GLOBAL* TURTLES-OWN-VARS: TURTLES-OWN-VAR* + PATCHES-OWN-VARS: PATCHES-OWN-VAR* GLOBAL: (GLOBAL-NAME GLOBAL-ACCESS-FUNC) ARGUMENTS AND VALUES: @@ -663,6 +664,7 @@ ARGUMENTS AND VALUES: YMIN: An integer representing the minimum patch coord in Y 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 GLOBAL-NAME: Symbol for the global in the keyword package GLOBAL-ACCESS-FUNC: Function to get the value of the global @@ -673,6 +675,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 *patches-own-vars* patches-own-vars) (setf *dimensions* dims) (setf *globals* globals) (setf *breeds* (list (list :turtles "default"))) @@ -774,14 +777,16 @@ DESCRIPTION: (append (list "\"PATCHES\"" - "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"") + (format nil "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"~{,\"~A\"~}" + (mapcar #'string-downcase *patches-own-vars*))) (mapcar (lambda (patch) (format nil - "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"" + "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\"~{,\"~A\"~}" (dump-object (patch-xcor patch)) (dump-object (patch-ycor patch)) - (dump-object (patch-color patch)))) + (dump-object (patch-color patch)) + (mapcar #'dump-object (mapcar (lambda (var) (agent-value-inner patch var)) *patches-own-vars*)))) *patches*))) (defun export-world () diff --git a/src/main/package.lisp b/src/main/package.lisp index 38d7ca0..92796dc 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) + (:export #:parse #:globals #:procedures #:turtles-own-vars #:patches-own-vars) (:documentation "CLNL Code Parser diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index 6202c51..aa9b22b 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -61,3 +61,28 @@ to go end" "setup go" "F8A2BFD71A8A064C37DDB744217AB07CDB0686EB") + +(defmodelcommandtest "patches-own 1" + "patches-own [a] +to setup + ask patches [ + set a 2 + ] +end" + "setup" + "73FE87B52A2DAB0EC02DB23F26DB3B5336A61679") + +(defmodelcommandtest "patches-own 2" + "patches-own [a b] +to setup + ask patches [ + set a 2 + set b a + 1 + ] +end + +to go + ask patches [ set pcolor b ] +end" + "setup go" + "2972B3EC1285BDA17656401001E1AE667FA7F5AF")