From 75a961089cba4b6aa4a3e947616ee4026ec3b057 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Tue, 19 Apr 2016 08:52:05 -0500 Subject: [PATCH] Torus topography v1 - fd works --- resources/empty.nlogo | 4 ++-- src/main/clnl.asd | 7 +++++-- src/main/lex.lisp | 2 +- src/main/nvm/base.lisp | 11 +++++++++++ src/main/{ => nvm}/nvm.lisp | 36 ++++++++++++++++++++---------------- src/main/nvm/topology.lisp | 20 ++++++++++++++++++++ src/main/nvm/utils.lisp | 6 ++++++ src/main/package.lisp | 2 +- src/test/clnl-test.asd | 18 +++++++++--------- src/test/simpletests.lisp | 18 ++++++++++++++---- 10 files changed, 89 insertions(+), 35 deletions(-) create mode 100644 src/main/nvm/base.lisp rename src/main/{ => nvm}/nvm.lisp (92%) create mode 100644 src/main/nvm/topology.lisp create mode 100644 src/main/nvm/utils.lisp diff --git a/resources/empty.nlogo b/resources/empty.nlogo index 7777839..5506350 100644 --- a/resources/empty.nlogo +++ b/resources/empty.nlogo @@ -4,8 +4,8 @@ GRAPHICS-WINDOW 10 649 470 -1 -1 +-1 +-1 13.0 1 10 diff --git a/src/main/clnl.asd b/src/main/clnl.asd index 29e33cc..d03aee3 100644 --- a/src/main/clnl.asd +++ b/src/main/clnl.asd @@ -7,10 +7,13 @@ (:file "model") (:file "lex") (:file "parse") - (:file "nvm") + (:file "nvm/base") + (:file "nvm/utils") + (:file "nvm/nvm") + (:file "nvm/topology") (:file "transpile") (:file "random") (:file "interface") (:file "cli") (:file "main")) - :depends-on #-travis (:cl-ppcre :mt19937 :cl-opengl :cl-glut :cl-charms :strictmath) #+travis nil) + :depends-on #-travis(:cl-ppcre :mt19937 :cl-opengl :cl-glut :cl-charms :ieee-floats :strictmath) #+travis nil) diff --git a/src/main/lex.lisp b/src/main/lex.lisp index d39ab59..bea4f5a 100644 --- a/src/main/lex.lisp +++ b/src/main/lex.lisp @@ -104,7 +104,7 @@ DESCRIPTION: (let ((*readtable* (copy-readtable nil)) (*read-eval* nil)) - (read-from-string text)))) + (read-from-string (format nil "~Ad0" text))))) (if (numberp num?) num? (error "Invalid number"))))) (deflex :initial (format nil "~A*" *identifier-char*) #'as-symbol) diff --git a/src/main/nvm/base.lisp b/src/main/nvm/base.lisp new file mode 100644 index 0000000..ea427fa --- /dev/null +++ b/src/main/nvm/base.lisp @@ -0,0 +1,11 @@ +(in-package #:clnl-nvm) + +(defvar *current-id* 0) + +(defvar *turtles* nil) +(defvar *myself* nil) +(defvar *self* nil) +(defvar *model* nil) +(defvar *topology* :torus) + +(defstruct turtle who color heading xcor ycor) diff --git a/src/main/nvm.lisp b/src/main/nvm/nvm.lisp similarity index 92% rename from src/main/nvm.lisp rename to src/main/nvm/nvm.lisp index 018ce7e..b18faf1 100644 --- a/src/main/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -1,12 +1,6 @@ (in-package #:clnl-nvm) -(defvar *current-id* 0) - -(defstruct turtle who color heading xcor ycor) -(defvar *turtles* nil) -(defvar *myself* nil) -(defvar *self* nil) -(defvar *model* nil) +; Implementations of all the things the nvm can do. (defun show (value) "SHOW VALUE => RESULT @@ -121,6 +115,17 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#random-float" (clnl-random:next-double n)) +(defun jump (n) + (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) + (setf + (turtle-xcor *self*) + (wrap-x *topology* + (+ (turtle-xcor *self*) (* n (strictmath:sin (strictmath:to-radians (turtle-heading *self*))))))) + (setf + (turtle-ycor *self*) + (wrap-y *topology* + (+ (turtle-ycor *self*) (* n (strictmath:cos (strictmath:to-radians (turtle-heading *self*)))))))) + (defun forward (n) "FORWARD N => RESULT @@ -141,12 +146,13 @@ DESCRIPTION: See http://ccl.northwestern.edu/netlogo/docs/dictionary.html#forward" (when (not (turtle-p *self*)) (error "Gotta call fd in turtle scope, dude (~A)" *self*)) - (setf - (turtle-xcor *self*) - (+ (turtle-xcor *self*) (* n (strictmath:sin (strictmath:to-radians (turtle-heading *self*)))))) - (setf - (turtle-ycor *self*) - (+ (turtle-ycor *self*) (* n (strictmath:cos (strictmath:to-radians (turtle-heading *self*))))))) + (labels + ((internal (i) + (cond + ((< (abs i) 3.2e-15) nil) + ((< (abs i) 1d0) (jump i)) + (t (jump (if (> i 0d0) 1d0 -1d0)) (internal (- i (if (> i 0d0) 1d0 -1d0))))))) + (internal n))) (defun create-turtles (n) "CREATE-TURTLES N => RESULT @@ -264,9 +270,7 @@ DESCRIPTION: "\"min-pxcor\",\"max-pxcor\",\"min-pycor\",\"max-pycor\",\"perspective\",\"subject\"," "\"nextIndex\",\"directed-links\",\"ticks\",") (format nil "\"~A\",\"~A\",\"~A\",\"~A\",\"0\",\"nobody\",\"~A\",\"\"\"NEITHER\"\"\",\"-1\"" - (getf (clnl-model:world-dimensions *model*) :xmin) (getf (clnl-model:world-dimensions *model*) :xmax) - (getf (clnl-model:world-dimensions *model*) :ymin) (getf (clnl-model:world-dimensions *model*) :ymax) - *current-id*) + (min-pxcor) (max-pxcor) (min-pycor) (max-pycor) *current-id*) "" (format nil "~S" "TURTLES") (format nil "~A~A" diff --git a/src/main/nvm/topology.lisp b/src/main/nvm/topology.lisp new file mode 100644 index 0000000..d5fa64d --- /dev/null +++ b/src/main/nvm/topology.lisp @@ -0,0 +1,20 @@ +(in-package #:clnl-nvm) + +(defun wrap (pos min max) + (cond + ((>= pos max) (+ min (mod (- pos max) (- max min)))) + ((< pos min) + (let + ((res (- max (mod (- min pos) (- max min))))) + (if (< res max) res min))) ; If d is infinitesimal, may return max, which would be bad :( + (t pos))) + +(defgeneric wrap-x (topology x)) +(defgeneric wrap-y (topology y)) + +; Torus implementations +(defmethod wrap-x ((topology (eql :torus)) x) + (wrap x (- (min-pxcor) 0.5d0) (+ (max-pxcor) 0.5d0))) + +(defmethod wrap-y ((topology (eql :torus)) y) + (wrap y (- (min-pycor) 0.5d0) (+ (max-pycor) 0.5d0))) diff --git a/src/main/nvm/utils.lisp b/src/main/nvm/utils.lisp new file mode 100644 index 0000000..06941f5 --- /dev/null +++ b/src/main/nvm/utils.lisp @@ -0,0 +1,6 @@ +(in-package #:clnl-nvm) + +(defun min-pxcor () (getf (clnl-model:world-dimensions *model*) :xmin)) +(defun max-pxcor () (getf (clnl-model:world-dimensions *model*) :xmax)) +(defun min-pycor () (getf (clnl-model:world-dimensions *model*) :ymin)) +(defun max-pycor () (getf (clnl-model:world-dimensions *model*) :ymax)) diff --git a/src/main/package.lisp b/src/main/package.lisp index 73202aa..207fc87 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -91,7 +91,7 @@ a command line interface program with a view for display purposes only, this is where all the features that the traditional NetLogo UI lives.")) (defpackage #:clnl-model - (:use :common-lisp :cl-charms/low-level) + (:use :common-lisp) (:export #:default-model #:read-from-nlogo #:world-dimensions) (:documentation "CLNL Model diff --git a/src/test/clnl-test.asd b/src/test/clnl-test.asd index abb713d..8e0a9dd 100644 --- a/src/test/clnl-test.asd +++ b/src/test/clnl-test.asd @@ -1,10 +1,10 @@ (asdf:defsystem clnl-test - :name "Experiment Tests" - :maintainer "Frank Duncan (frank@kank.com)" - :author "Frank Duncan (frank@kank.com)" - :serial t - :components ((:file "package") - (:file "main") - (:file "simpletests") - (:file "viewtests")) - :depends-on (#-travis :ironclad :clnl)) + :name "Experiment Tests" + :maintainer "Frank Duncan (frank@kank.com)" + :author "Frank Duncan (frank@kank.com)" + :serial t + :components ((:file "package") + (:file "main") + (:file "simpletests") + (:file "viewtests")) + :depends-on (#-travis :ironclad :clnl)) diff --git a/src/test/simpletests.lisp b/src/test/simpletests.lisp index 68b460d..406df86 100644 --- a/src/test/simpletests.lisp +++ b/src/test/simpletests.lisp @@ -9,13 +9,23 @@ (defsimplecommandtest "Simple crt 2" "crt 5" "9FE588C2749CD9CE66CB0EA451EFB80476E881FB") +(defsimplecommandtest "Simple crt and fd random" "crt 30 ask turtles [ fd random-float 1 ]" + "DED34D1D6492244E9E3813DE8DBF258F96636879") + (defsimplecommandtest "Simple crt and fd" "crt 5 ask turtles [ fd 1 ]" "BEB43404EDC7852985A9A7FC312481785FE553A0") -(defsimplecommandtest "Simple crt and fd random" "crt 5 ask turtles [ fd random-float 1 ]" - "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870") -;(defsimplecommandtest "Simple crt and fd random 2" "crt 30 ask turtles [ fd random-float 1 ]" -; "F7AC3B3492CDFD01D1FB5BD69FAAA67E06D3A870") ; we start getting floating errors, cool! +(defsimplecommandtest "Wrapping 1" "crt 5 ask turtles [ fd 5 ]" + "1098A56973DA04E7AEA7659C40E3FF3EC7862B02") + +(defsimplecommandtest "Wrapping 2" "crt 5 ask turtles [ fd random-float 5 ]" + "1419DFA66EFB7F08FB30C7B63B256547212EB915") + +(defsimplecommandtest "Wrapping 3" "crt 10 ask turtles [ fd -5 ]" + "53E4ECBD3C49FC8D3466563641CFCD7DCB5CD2AF") + +(defsimplecommandtest "Wrapping 4" "crt 10 ask turtles [ fd random-float -5 ]" + "1258CE9CC93B52367E797F4C497BF95760EC7175") (defsimplereportertest "Random 1" "random-float 5" "4.244088516651127" "17D1BF7FF7BF2C7F3F5F7DD7CF67CFF2772CFFFC") -- 2.25.1