From: Frank Duncan Date: Mon, 25 Apr 2016 21:59:23 +0000 (-0500) Subject: Add patches X-Git-Tag: v0.1.0~40 X-Git-Url: https://code.consxy.com/gitweb/gitweb.cgi?a=commitdiff_plain;h=8b23537;p=clnl Add patches --- diff --git a/bin/run.lisp b/bin/run.lisp index 0cd8d8b..b59ef93 100644 --- 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 ba3efc5..c9cc432 100644 --- 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 dfd3fc2..ddd429e 100644 --- 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 47f5467..3c2e531 100644 --- 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 a5ccd6f..630280c 100644 --- 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"))