From: Frank Duncan <frank@kank.net>
Date: Mon, 9 May 2016 12:58:22 +0000 (-0500)
Subject: Code - turtles-own
X-Git-Tag: v0.1.0~17
X-Git-Url: https://code.consxy.com/gitweb/?a=commitdiff_plain;h=97c390f3cee5094fa6795acd4b25b7598d5dd1bd;p=clnl

Code - turtles-own
---

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")