From ef8590acac123b880b2719eaac691af310262cca Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Fri, 29 Apr 2016 22:35:50 -0500 Subject: [PATCH] Prims - Implement color, label, label-color, size --- src/main/base.lisp | 22 ++++++++++++++++++++++ src/main/clnl.asd | 1 + src/main/interface.lisp | 1 + src/main/main.lisp | 21 --------------------- src/main/nvm/agent.lisp | 8 +++++++- src/main/nvm/base.lisp | 2 +- src/main/nvm/nvm.lisp | 12 ++++++++---- src/main/transpile.lisp | 4 ++++ src/test/simpletests.lisp | 12 ++++++++++++ src/test/viewtests.lisp | 3 +++ 10 files changed, 59 insertions(+), 27 deletions(-) create mode 100644 src/main/base.lisp diff --git a/src/main/base.lisp b/src/main/base.lisp new file mode 100644 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 86c0570..1f90141 100644 --- 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 c9cc432..6033740 100644 --- 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 09244a0..eee8e48 100644 --- 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 c52ca3a..e26186e 100644 --- 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 2288537..9c49c99 100644 --- 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 f59e181..0a819ae 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -421,7 +421,7 @@ DESCRIPTION: ; Someday we'll have d, 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 e7e05de..1bac2b6 100644 --- 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 759d57b..efc71f7 100644 --- 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 ac39a15..9135e47 100644 --- 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")) -- 2.25.1