Add patches

diff --git a/bin/run.lisp b/bin/run.lisp
index 0cd8d8bc28d0d545fc804dbe91e5944a2a06eb6c..b59ef934c9364f524d82d213e7eaf8d117f92baf 100644 (file)
--- a/bin/run.lisp
+++ b/bin/run.lisp
@@ -1,4 +1,5 @@
 (setf *compile-print* nil)
 (require 'asdf)
+(asdf:initialize-source-registry `(:source-registry (:tree ,(car (directory "src"))) :INHERIT-CONFIGURATION))
 (asdf:load-system :clnl)
 (clnl:run)

diff --git a/src/main/interface.lisp b/src/main/interface.lisp
index ba3efc5fdc4961e3da75ed3a77ac4faab272fe47..c9cc43223b1dc4ac5c5f8ac5613aeb545de1d9ab 100644 (file)
--- a/src/main/interface.lisp
+++ b/src/main/interface.lisp
@@ -3,6 +3,7 @@
 (defvar *patch-size* 13d0)
 
 (defvar *turtle-list* nil)
+(defvar *patch-list* nil)
 
 ; It may be useful to keep windows around
 (defvar *glut-window-opened* nil)
@@ -40,21 +41,34 @@
  (gl:ortho -71 71 -71 71 1 5000)
  (gl:matrix-mode :modelview)
  (gl:load-identity)
- (mapcar
-  (lambda (turtle)
-   (let
-    ((color (nl-color->rgb (getf turtle :color))))
-    (gl:color (car color) (cadr color) (caddr color)))
-   (mapcar
-    (lambda (x-modification y-modification)
-     (gl:with-pushed-matrix
-      (gl:translate (* (getf turtle :xcor) *patch-size*) (* (getf turtle :ycor) *patch-size*) 0)
-      (gl:translate x-modification y-modification 0)
-      (gl:rotate (getf turtle :heading) 0 0 -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))))))
-  (clnl-nvm:current-state))
+ (destructuring-bind (turtles patches) (clnl-nvm:current-state)
+  (mapcar
+   (lambda (patch)
+    (let
+     ((color (nl-color->rgb (getf patch :color))))
+     (gl:color (car color) (cadr color) (caddr color)))
+    (gl:with-pushed-matrix
+     (gl:translate (* (getf patch :xcor) *patch-size*) (* (getf patch :ycor) *patch-size*) 0)
+     (gl:translate (floor (* -.5d0 *patch-size*)) (floor (* -.5d0 *patch-size*)) 0)
+     (gl:scale *patch-size* *patch-size* 1)
+     (gl:call-list *patch-list*)))
+   patches)
+  (mapcar
+   (lambda (turtle)
+    (let
+     ((color (nl-color->rgb (getf turtle :color))))
+     (gl:color (car color) (cadr color) (caddr color)))
+    (mapcar
+     (lambda (x-modification y-modification)
+      (gl:with-pushed-matrix
+       (gl:translate (* (getf turtle :xcor) *patch-size*) (* (getf turtle :ycor) *patch-size*) 0)
+       (gl:translate x-modification y-modification 0)
+       (gl:rotate (getf turtle :heading) 0 0 -1)
+       (gl:scale *patch-size* *patch-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))))))
+   turtles))
  (gl:flush))
 
 (defun display ()
@@ -80,7 +94,7 @@
  (setf *turtle-list* (gl:gen-lists 1))
  (gl:with-new-list (*turtle-list* :compile)
   (gl:rotate 180 0 0 -1)
-  (gl:scale (* (/ 1d0 300d0) 13) (* (/ 1d0 300d0) 13) 1)
+  (gl:scale (/ 1d0 300d0) (/ 1d0 300d0) 1)
   (gl:translate -150 -150 -4.0)
   (gl:begin :polygon)
   (gl:vertex 150 5 0)
@@ -89,6 +103,17 @@
   (gl:vertex 260 250 0)
   (gl:end)))
 
+(defun set-patch-list ()
+ (setf *patch-list* (gl:gen-lists 1))
+ (gl:with-new-list (*patch-list* :compile)
+  (gl:translate 0d0 0d0 -4.0)
+  (gl:begin :polygon)
+  (gl:vertex 0 0 0)
+  (gl:vertex 0 1 0)
+  (gl:vertex 1 1 0)
+  (gl:vertex 1 0 0)
+  (gl:end)))
+
 (defun initialize (&key dims)
  "INITIALIZE &key DIMS => RESULT
 
@@ -140,6 +165,7 @@ DESCRIPTION:
   (cl-glut:idle-func (cffi:get-callback 'idle))
   (cl-glut:close-func (cffi:get-callback 'close-func))
   (set-turtle-list)
+  (set-patch-list)
   (cl-glut:main-loop)))
 
 (defun world-width-in-pixels ()
@@ -172,6 +198,7 @@ DESCRIPTION:
    (cl-glut:create-window "CLNL Test Window")
    (gl:clear-color 0 0 0 1)
    (set-turtle-list)
+   (set-patch-list)
    (setf *glut-window-opened* t))
   (let
    ((fbo (first (gl:gen-framebuffers 1)))

diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp
index dfd3fc2172fb1ce0de5f95c092790e5722a9f1dd..ddd429ee265cf9ca01825340f13b340db20960d2 100644 (file)
--- a/src/main/nvm/base.lisp
+++ b/src/main/nvm/base.lisp
@@ -3,9 +3,11 @@
 (defvar *current-id* 0)
 
 (defvar *turtles* nil)
+(defvar *patches* nil)
 (defvar *myself* nil)
 (defvar *self* nil)
 (defvar *dimensions* nil)
 (defvar *topology* :torus)
 
 (defstruct turtle who color heading xcor ycor)
+(defstruct patch color xcor ycor)

diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp
index 47f5467ac35ece66adf49521293d0ba2a08f8ee7..3c2e531c4933a6173c045b58f6a3c3c2a63a0d19 100644 (file)
--- a/src/main/nvm/nvm.lisp
+++ b/src/main/nvm/nvm.lisp
@@ -284,6 +284,16 @@ 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 *dimensions* dims)
+ (setf
+  *patches*
+  (loop
+   :for y :from (max-pycor) :downto (min-pycor)
+   :append (loop
+            :for x :from (min-pxcor) :to (max-pxcor)
+            :collect (make-patch
+                      :xcor (coerce x 'double-float)
+                      :ycor (coerce y 'double-float)
+                      :color 0d0))))
  (setf *turtles* nil)
  (setf *current-id* 0))
 
@@ -319,31 +329,59 @@ DESCRIPTION:
   data structure for easy usage in a common lisp instance.  It's preferable
   to use this when working with the nvm than the output done by export-world.
 
-  Currently this only dumps out turtle information.
+  Currently this only dumps out turtle and patch information.
 
   This is called CURRENT-STATE because export-world is an actual primitive
   used by NetLogo."
- (mapcar
-  (lambda (turtle)
-   (list
-    :color (turtle-color turtle)
-    :xcor (turtle-xcor turtle)
-    :ycor (turtle-ycor turtle)
-    :heading (turtle-heading turtle)))
-  *turtles*))
+ (list
+  (mapcar
+   (lambda (turtle)
+    (list
+     :color (turtle-color turtle)
+     :xcor (turtle-xcor turtle)
+     :ycor (turtle-ycor turtle)
+     :heading (turtle-heading turtle)))
+   *turtles*)
+  (mapcar
+   (lambda (patch)
+    (list
+     :color (patch-color patch)
+     :xcor (patch-xcor patch)
+     :ycor (patch-ycor patch)))
+   *patches*)))
+
+(defun export-turtles ()
+ (append
+  (list
+   "\"TURTLES\""
+   (format nil "~A~A"
+    "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
+    "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\""))
+  (mapcar
+   (lambda (turtle)
+    (format nil
+     "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
+     (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\"\"\""))
+   *turtles*)))
 
 (defun export-patches ()
- (list
-  "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\""
-  "\"-1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"0\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"1\",\"1\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"-1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"0\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"1\",\"0\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"-1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"0\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""
-  "\"1\",\"-1\",\"0\",\"\"\"\"\"\",\"9.9\""))
+ (append
+  (list
+   "\"PATCHES\""
+   "\"pxcor\",\"pycor\",\"pcolor\",\"plabel\",\"plabel-color\"")
+  (mapcar
+   (lambda (patch)
+    (format nil
+     "\"~A\",\"~A\",\"~A\",\"\"\"\"\"\",\"9.9\""
+     (dump-object (patch-xcor patch))
+     (dump-object (patch-ycor patch))
+     (dump-object (patch-color patch))))
+   *patches*)))
 
 (defun export-world ()
  "EXPORT-WORLD => WORLD-CSV
@@ -371,23 +409,8 @@ DESCRIPTION:
    (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\""
     (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*)
    ""
-   (format nil "~S" "TURTLES")
-   (format nil "~A~A"
-    "\"who\",\"color\",\"heading\",\"xcor\",\"ycor\",\"shape\",\"label\",\"label-color\","
-    "\"breed\",\"hidden?\",\"size\",\"pen-size\",\"pen-mode\"")
-   (format nil "~{~A~%~}"
-    (mapcar
-     (lambda (turtle)
-      (format nil
-       "\"~A\",\"~A\",\"~A\",\"~A\",\"~A\",~A"
-       (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\"\"\""))
-     *turtles*))
-   (format nil "~S" "PATCHES")
+   (format nil "~{~A~^~%~}" (export-turtles))
+   ""
    (format nil "~{~A~^~%~}" (export-patches))
    ""
    (format nil "~S" "LINKS")

diff --git a/src/test/viewtests.lisp b/src/test/viewtests.lisp
index a5ccd6f203f6624217fad82647ade9a49f8941e4..630280c81f23787cceab29d6298e97c959ee8b2a 100644 (file)
--- a/src/test/viewtests.lisp
+++ b/src/test/viewtests.lisp
@@ -1,22 +1,22 @@
 (in-package #:clnl-test)
 
 (defviewtest "Nothing" ""
- "1AF55686BD9B18D1CCE6AAF6BF18E81E6957F466")
+ "62B8B468D5ED63CDFB567C984E0CAB53DBD03CEB")
 
 (defviewtest "Basic 1" "crt 1"
- "A41D8146DD81EF27AF2B97955C66E982CFA0A465")
+ "67F7062D7485C3A31D0065549AB8BED71A48BFEE")
 
 (defviewtest "Basic 2" "crt 10 ask turtles [ fd 1 ]"
- '("DEC2ED793C08A1680DD601BD3E9B81927994C123" "788EAE5B41CE031672672C372EDBCDFD9B309E64"))
+ '("FC3B914602A7F41C5044B7A605DFF36D866B3A7F" "E09857180035872901B8BE27FE5470FD3D987966"))
 
 (defviewtest "Wrapping" "crt 10 ask turtles [ fd 6 ]"
- '("DCDA6106352BBB6B52878B7AA443BCD5B7D124FC" "36922B55C2307FF4C7F2240B0A84C6D7B52427F9"))
+ '("72065F4E85CAE90DCFAE85AFC5A09295D46CD3D0" "CAABD296A8C72B18401F19C14C0DC83BB07718A9"))
 
 (defviewtest "Die" "crt 10 ask turtles [ fd 1 ] ask turtles [ die ]"
- "1AF55686BD9B18D1CCE6AAF6BF18E81E6957F466")
+ "62B8B468D5ED63CDFB567C984E0CAB53DBD03CEB")
 
 (defviewtest "rt" "crt 20 ask turtles [ fd 2 rt 100 fd 2 ]"
- '("32CBE504D9BE79DD62163ECD684DAA54901C8DA2" "7DF601FF1857672EBFADC8414C0744AA2841E117"))
+ '("7E4DB3DBDE0F1C7D821629B89B8DC20ECFBF06AD" "9143414BB6DF425455C7ACBA6620FD51C9EC5E3A"))
 
 (defviewtest "lt" "crt 20 ask turtles [ fd 2 lt 100 fd 2 ]"
- '("B3DC43E676A804A5C42200E688D5AA6921DF95F2" "236B06E6383BC75B7C9E1E7BBF4B7D416AE72411"))
+ '("BF49775097BBFAE12E42D6F13FAFC93090B7ACAC" "ABAEAF8DDD68E7F0FED6CB243F27DB312588A1E8"))