Code - patches-own

diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp
index d40f7bad59ce28fa936f73268609505e44026981..b2a9e4508e89039f8ae91f5cd2b08910201c6480 100644 (file)
--- 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 6f319c48fe5abd7cc944c08b48c69d123db6d987..29c50ea646b5f9378accfc62cd981914e3b32c52 100644 (file)
--- 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 ee1d97136ad72593b48c51fa2db6e1f47babbb04..8e97ea002c5bdf5ff4c06e12c8cd5a2b04ef9283 100644 (file)
--- 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 54d0246b62c7932341a5827b60e5fba378e1557a..945c5e8ea01e02dbad5d87b7ad9ba45f48960357 100644 (file)
--- 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 dcba15148fee16839967859fd016dea94fb50a6c..42a269a35be376cb7ab50b8bdf70e1163026b62c 100644 (file)
--- 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 38d7ca065532ae4b34f108dfec3eb43a9caf5e40..92796dc095a346d491bcf6ffd2517721daaa433c 100644 (file)
--- 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 6202c51e2df1a752041bc8f154803590b0300b54..aa9b22b0bc0835577891b194b1ca580ed2d26c6b 100644 (file)
--- 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")