Prims - Implement color, label, label-color, size

diff --git a/src/main/base.lisp b/src/main/base.lisp
new file mode 100644 (file)
index 0000000..f90c77f
--- /dev/null
+++ b/src/main/base.lisp
@@ -0,0 +1,22 @@
+(in-package #:clnl)
+
+(defvar *model-package* (find-package :cl-user)
+ "*MODEL-PACKAGE*
+
+VALUE TYPE:
+
+  a package
+
+INITIAL VALUE:
+
+  The common-lisp-user package
+
+DESCRIPTION:
+
+  *MODEL-PACKAGE* is used for interning symbols as a NetLogo code
+  gets compiled.
+
+  Any local symbols are interned in this package, for use either
+  by other code, or in order to have all symbols interned in the
+  same placakge.  This is also the package in which a model should
+  be run, whether by clnl code or independently.")

diff --git a/src/main/clnl.asd b/src/main/clnl.asd
index 86c0570d8333ccd2da77e7ede87a4b4c2eef069a..1f901411e37ceb347ea0c66fa9f0212b4c69fd76 100644 (file)
--- a/src/main/clnl.asd
+++ b/src/main/clnl.asd
@@ -4,6 +4,7 @@
  :maintainer "Frank Duncan (frank@kank.com)"
  :author "Frank Duncan (frank@kank.com)"
  :components ((:file "package")
+              (:file "base")
               (:file "model")
               (:file "lex")
               (:file "parse")

diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index c9cc43223b1dc4ac5c5f8ac5613aeb545de1d9ab..6033740249a3be3843873e70b9d670e1056cb948 100644 (file)
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -65,6 +65,7 @@
        (gl:translate x-modification y-modification 0)
        (gl:rotate (getf turtle :heading) 0 0 -1)
        (gl:scale *patch-size* *patch-size* 1)
+       (gl:scale (getf turtle :size) (getf turtle :size) 1)
        (gl:call-list *turtle-list*)))
      (list 0 (1- (world-width-in-pixels)) (- (1- (world-width-in-pixels))) 0 0)
      (list 0 0 0 (1- (world-height-in-pixels)) (- (1- (world-height-in-pixels))))))

diff --git a/src/main/main.lisp b/src/main/main.lisp
index 09244a02229c2f11e8c54799557cef8dae6985a3..eee8e48f48b6e7930f5cff269f6b378a7825b058 100644 (file)
--- a/src/main/main.lisp
+++ b/src/main/main.lisp
@@ -1,26 +1,5 @@
 (in-package #:clnl)
 
-(defvar *model-package* (find-package :cl-user)
- "*MODEL-PACKAGE*
-
-VALUE TYPE:
-
-  a package
-
-INITIAL VALUE:
-
-  The common-lisp-user package
-
-DESCRIPTION:
-
-  *MODEL-PACKAGE* is used for interning symbols as a NetLogo code
-  gets compiled.
-
-  Any local symbols are interned in this package, for use either
-  by other code, or in order to have all symbols interned in the
-  same placakge.  This is also the package in which a model should
-  be run, whether by clnl code or independently.")
-
 (defun e (ast) ast)
 
 (defun r (str)

diff --git a/src/main/nvm/agent.lisp b/src/main/nvm/agent.lisp
index c52ca3a3dcb38f95d4ed56e14a27c309d9627781..e26186e206d288f99816bf52d490e646c422f932 100644 (file)
--- a/src/main/nvm/agent.lisp
+++ b/src/main/nvm/agent.lisp
@@ -35,6 +35,12 @@ DESCRIPTION:
     (defmethod agent-value-inner ((,agent ,type) (,var (eql ,symb))) (,accessor ,agent))
     (defmethod set-agent-value-inner ((,agent ,type) (,var (eql ,symb)) ,new-val) (setf (,accessor ,agent) ,new-val)))))
 
-(defagent-value turtle :who)
+; Don't want the setter for :who
+(defmethod agent-value-inner ((agent turtle) (var (eql :who))) (turtle-who agent))
 
 (defagent-value patch :pcolor patch-color)
+
+(defagent-value turtle :color)
+(defagent-value turtle :label)
+(defagent-value turtle :label-color)
+(defagent-value turtle :size)

diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp
index 228853767bde0968e763e7bd955314db5805e4e0..9c49c9900bbd35d308e837fbeabc47dbb8a44193 100644 (file)
--- a/src/main/nvm/base.lisp
+++ b/src/main/nvm/base.lisp
@@ -10,7 +10,7 @@
 (defvar *topology* :torus)
 (defvar *ticks* nil)
 
-(defstruct turtle who color heading xcor ycor)
+(defstruct turtle who color heading xcor ycor (label "") (label-color 9.9d0) (size 1d0))
 (defstruct patch color xcor ycor)
 
 (defun agent-set-list (agent-set)

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index f59e18138a0bd1d1d0b874f7284ab058c85a8c21..0a819ae4041322011e584b7dda08a59f2f792863 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -421,7 +421,7 @@ DESCRIPTION:
     ; Someday we'll have d<posint>, but this is not that day!
     (cl-ppcre:regex-replace "d-" (cl-ppcre:regex-replace "d0" output "") "E-")))))
 
-(defmethod dump-object ((o string)) o)
+(defmethod dump-object ((o string)) (format nil "~A" (cl-ppcre:regex-replace-all "\"" (format nil "~S" o) "\"\"")))
 
 (defmethod dump-object ((o (eql t))) "true")
 (defmethod dump-object ((o (eql nil))) "false")
@@ -460,7 +460,8 @@ DESCRIPTION:
      :color (turtle-color turtle)
      :xcor (turtle-xcor turtle)
      :ycor (turtle-ycor turtle)
-     :heading (turtle-heading turtle)))
+     :heading (turtle-heading turtle)
+     :size (turtle-size turtle)))
    *turtles*)
   (mapcar
    (lambda (patch)
@@ -480,13 +481,16 @@ DESCRIPTION:
   (mapcar
    (lambda (turtle)
     (format nil
-     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
+     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",\"\"\"default\"\"\",\"~A\",\"~A\",\"{all-turtles}\",\"false\",\"~A\",~A"
      (dump-object (turtle-who turtle))
      (dump-object (turtle-color turtle))
      (dump-object (turtle-heading turtle))
      (dump-object (turtle-xcor turtle))
      (dump-object (turtle-ycor turtle))
-     "\"\"\"default\"\"\",\"\"\"\"\"\",\"9.9\",\"{all-turtles}\",\"false\",\"1\",\"1\",\"\"\"up\"\"\""))
+     (dump-object (turtle-label turtle))
+     (dump-object (turtle-label-color turtle))
+     (dump-object (turtle-size turtle))
+     "\"1\",\"\"\"up\"\"\""))
    *turtles*)))
 
 (defun export-patches ()

diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp
index e7e05de93e8b83b63520895910bcd41e83e3d8b1..1bac2b6701500cde209f8cda61ed09338c2152c0 100644 (file)
--- a/src/main/transpile.lisp
+++ b/src/main/transpile.lisp
@@ -140,6 +140,7 @@ DESCRIPTION:
 (defsimpleprim :/ :reporter cl:/)
 (defprim :any? :reporter (lambda (agentset) `(> (length ,agentset) 0)))
 (defsimpleprim :ask :command clnl-nvm:ask)
+(defagentvalueprim :color)
 (defsimpleprim :crt :command clnl-nvm:create-turtles)
 (defsimpleprim :die :command clnl-nvm:die)
 (defsimpleprim :fd :command clnl-nvm:forward)
@@ -150,6 +151,8 @@ DESCRIPTION:
                              ,@(make-command-block-inline b))))
 
 (defprim-alias :if-else :ifelse)
+(defagentvalueprim :label)
+(defagentvalueprim :label-color)
 (defsimpleprim :lt :command clnl-nvm:turn-left)
 (defkeywordprim :nobody)
 (defsimpleprim :one-of :reporter clnl-nvm:one-of)
@@ -161,6 +164,7 @@ DESCRIPTION:
 (defsimpleprim :rt :command clnl-nvm:turn-right)
 (defsimpleprim :show :command clnl-nvm:show)
 (defsimpleprim :set :command cl:setf)
+(defagentvalueprim :size)
 (defsimpleprim :tick :command clnl-nvm:tick)
 (defsimpleprim :ticks :reporter clnl-nvm:ticks)
 (defsimpleprim :turtles :reporter clnl-nvm:turtles)

diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp
index 759d57b7f85d1053a6fab130d91d8e6e640f52d4..efc71f7359f316fe5e4875ca282c56394f00f924 100644 (file)
--- a/src/test/simpletests.lisp
+++ b/src/test/simpletests.lisp
@@ -165,3 +165,15 @@
 
 (defreportertestwithsetup "one-of 3" "crt 10" "one-of turtles" "(turtle 5)"
  "A056ED8BF26A69FB4437E79F263E362C27F8820E")
+
+(defsimplecommandtest "color 1" "crt 10 ask turtles [ set color green ]"
+ "20943094E2C70D5A12AC6EEB29E8E9E2D21BD87D")
+
+(defsimplecommandtest "label 1" "crt 10 ask turtles [ set label who ]"
+ "96BF63544678A06E0D9A5062613CE1CAD638FCD5")
+
+(defsimplecommandtest "label-color 1" "crt 10 ask turtles [ set label-color green ]"
+ "70AB2BAA0BFD312256DDE6C02EE2B9C23E9B3532")
+
+(defsimplecommandtest "size 1" "crt 10 ask turtles [ set size 5 ]"
+ "8837CF2681A2091B0664FAA2C32062B19F548ED6")

diff --git a/src/test/viewtests.lisp b/src/test/viewtests.lisp
index ac39a155fbbaac72d5b7318aef9dc2d207e17448..9135e47106404886ab65dfd89c252caaaa5df4fb 100644 (file)
--- a/src/test/viewtests.lisp
+++ b/src/test/viewtests.lisp
@@ -23,3 +23,6 @@
 
 (defviewtest "pcolor green" "ask patches [ set pcolor green ]"
  "90F5F4870955B9FF02224F00E3C9814B8A6F766E")
+
+(defviewtest "size" "crt 10 ask turtles [ fd 2 set size 3 ] "
+ '("66E47E4579C2CA48CA672052B99F25DE94456D3A" "0A8EC908783A913CD15E9A0F19E6B8DBBA4EF5D9"))