Code - turtles-own

diff --git a/src/main/code-parse.lisp b/src/main/code-parse.lisp
index d1b30ee7ff93a78f7ff2643385b2a9d839ed5aa9..d40f7bad59ce28fa936f73268609505e44026981 100644 (file)
--- 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 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))))
 (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
   (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)
     (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)
       (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:
 
 
   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:
   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)))))
 
   (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)
 (defun procedures (code-parsed-ast)

- "PROCEDURES MODEL => PROCEDURES
+ "PROCEDURES CODE-PARSED-AST => PROCEDURES

 
   PROCEDURES: PROCEDURE*
   PROCEDURE: (NAME BODY)
 
 ARGUMENTS AND VALUES:
 
 
   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
 
   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 9862515065b33a5bd3e550bfe8d57aabf2e07e15..6f319c48fe5abd7cc944c08b48c69d123db6d987 100644 (file)
--- 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*))))
                   ,@(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)
        ,@(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 (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*))
       ,@(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 e26186e206d288f99816bf52d490e646c422f932..ee1d97136ad72593b48c51fa2db6e1f47babbb04 100644 (file)
--- 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 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)
 
 
 (defagent-value patch :pcolor patch-color)
 


@@ -44,3 +44,13 @@ DESCRIPTION:
 (defagent-value turtle :label)
 (defagent-value turtle :label-color)
 (defagent-value turtle :size)
 (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 af87bc27e167f68c320a51009d59087bb22b60d6..54d0246b62c7932341a5827b60e5fba378e1557a 100644 (file)
--- a/src/main/nvm/base.lisp
+++ b/src/main/nvm/base.lisp
@@ -3,6 +3,7 @@
 (defvar *current-id* 0)
 
 (defvar *turtles* nil)
 (defvar *current-id* 0)
 
 (defvar *turtles* nil)

+(defvar *turtles-own-vars* nil)

 (defvar *patches* nil)
 (defvar *myself* nil)
 (defvar *self* 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)))
 
   :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)
 (defstruct patch color xcor ycor)
 
 (defun agentset-list (agentset)

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 766df5379bf232623274271bbc58c7273cdf23ce..dcba15148fee16839967859fd016dea94fb50a6c 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 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*
 
   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:
 
 
 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
   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:
 
 
 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."
 
   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")))
  (setf *dimensions* dims)
  (setf *globals* globals)
  (setf *breeds* (list (list :turtles "default")))


@@ -746,13 +749,14 @@ DESCRIPTION:
  (append
   (list
    "\"TURTLES\""
  (append
   (list
    "\"TURTLES\""

-   (format nil "~A~A"
+   (format nil "~A~A~{,\"~A\"~}"

     "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
     "\"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
   (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))
      (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))
      (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 ()
    *turtles*)))
 
 (defun export-patches ()

diff --git a/src/main/package.lisp b/src/main/package.lisp
index 675a70ba7ea4fe7404b7230189fdf982955d3bd6..38d7ca065532ae4b34f108dfec3eb43a9caf5e40 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)
 
 (defpackage #:clnl-code-parser
  (:use :common-lisp)

- (:export #:parse #:globals #:procedures)
+ (:export #:parse #:globals #:procedures #:turtles-own-vars)

  (:documentation
   "CLNL Code Parser
 
  (:documentation
   "CLNL Code Parser
 

diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp
index 071aa09e511de2c53cd479912787572ab574a7ee..6202c51e2df1a752041bc8f154803590b0300b54 100644 (file)
--- a/src/test/modeltests.lisp
+++ b/src/test/modeltests.lisp
@@ -36,3 +36,28 @@ to go
 end"
  "go"
  "46C620AB8995266C4A2094C461BE197BBACEB8C3")
 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")