Forever Buttons - Handle stop correctly

diff --git a/.travis.yml b/.travis.yml
index 53ba83def01c69c02482f0bde8455682b5812575..074107d57e0d1aae8aa009b45d4ba618ae96edc9 100644 (file)
--- a/.travis.yml
+++ b/.travis.yml
@@ -6,7 +6,7 @@ addons:
 before_install:
   - export DISPLAY=:99.0
   - /sbin/start-stop-daemon --start --quiet --pidfile /tmp/custom_xvfb_99.pid --make-pidfile --background --exec /usr/bin/Xvfb -- :99 -ac -screen 0 1280x1024x24
-  - wget http://frank.kank.net/travissbcl/clnl/a66006d/$(git rev-parse HEAD)/travissbcl
+  - wget http://frank.kank.net/travissbcl/clnl/6e06e22/$(git rev-parse HEAD)/travissbcl
   - chmod +x travissbcl
 script:
-  - ./travissbcl --dynamic-space-size 3072 --script bin/all.lisp
+  - ./travissbcl --dynamic-space-size 4096 --script bin/all.lisp

diff --git a/bin/buildlinuxexec.sh b/bin/buildlinuxexec.sh
index c38409751cfd98f159f32aa40d798150f8dbe9bf..327e32df225c3f5c55681d19592875dc67a8760b 100755 (executable)
--- a/bin/buildlinuxexec.sh
+++ b/bin/buildlinuxexec.sh
@@ -15,7 +15,7 @@ cwd=$PWD
 mkdir -p tmp/deps/
 
 ( cd tmp/deps &&
-  tar zxf ../../deps/common-lisp/clnl-gltk_0.1.tar.gz &&
+  tar zxf ../../deps/common-lisp/clnl-gltk_0.2.tar.gz &&
   tar zxf ../../deps/common-lisp/3b-cl-opengl-993d627.tar.gz &&
   tar zxf ../../deps/common-lisp/alexandria-b1c6ee0.tar.gz &&
   tar zxf ../../deps/common-lisp/babel_0.5.0.tar.gz &&

diff --git a/bin/buildosxexec.sh b/bin/buildosxexec.sh
index 88a451d7631d54b06a5e04f34695e376d77769ff..17657ee52a4eec61f49967d19d09e1efa58875b4 100755 (executable)
--- a/bin/buildosxexec.sh
+++ b/bin/buildosxexec.sh
@@ -19,7 +19,7 @@ cwd=$PWD
 mkdir -p tmp/deps/
 
 ( cd tmp/deps &&
-  tar zxf ../../deps/common-lisp/clnl-gltk_0.1.tar.gz &&
+  tar zxf ../../deps/common-lisp/clnl-gltk_0.2.tar.gz &&
   tar zxf ../../deps/common-lisp/3b-cl-opengl-993d627.tar.gz &&
   tar zxf ../../deps/common-lisp/alexandria-b1c6ee0.tar.gz &&
   tar zxf ../../deps/common-lisp/babel_0.5.0.tar.gz &&

diff --git a/bin/buildtravisexec.sh b/bin/buildtravisexec.sh
index cdf907603ae4099796757b35540e87aa110a5cf2..8ca2bf7c9ed6db2e2b3f6b3340d831ed111661c5 100755 (executable)
--- a/bin/buildtravisexec.sh
+++ b/bin/buildtravisexec.sh
@@ -25,7 +25,7 @@ mkdir -p tmp/deps/
   tar zxf ../../deps/common-lisp/nibbles-v0.12.tar.gz &&
   tar zxf ../../deps/common-lisp/trivial-features_0.8.tar.gz &&
   tar zxf ../../deps/common-lisp/style-checker_0.1.tar.gz &&
-  tar zxf ../../deps/common-lisp/clnl-gltk_0.1.tar.gz &&
+  tar zxf ../../deps/common-lisp/clnl-gltk_0.2.tar.gz &&
   tar zxf ../../deps/common-lisp/docgen_0.3.tar.gz &&
   tar zxf ../../deps/common-lisp/ieee-floats-92e481a.tar.gz &&
   tar zxf ../../deps/common-lisp/strictmath_0.1.tar.gz

diff --git a/bin/buildwindowsexec.sh b/bin/buildwindowsexec.sh
index 6f67f3fbb057c2f65eac2ad865a646114528ac91..6978071e0a73236477aee612c259f883fceee773 100755 (executable)
--- a/bin/buildwindowsexec.sh
+++ b/bin/buildwindowsexec.sh
@@ -21,7 +21,7 @@ fi
 mkdir -p tmp/deps/
 
 ( cd tmp/deps &&
-  tar zxf ../../deps/common-lisp/clnl-gltk_0.1.tar.gz &&
+  tar zxf ../../deps/common-lisp/clnl-gltk_0.2.tar.gz &&
   tar zxf ../../deps/common-lisp/3b-cl-opengl-993d627.tar.gz &&
   tar zxf ../../deps/common-lisp/alexandria-b1c6ee0.tar.gz &&
   tar zxf ../../deps/common-lisp/babel_0.5.0.tar.gz &&

diff --git a/deps/common-lisp/clnl-gltk_0.1.tar.gz b/deps/common-lisp/clnl-gltk_0.1.tar.gz
deleted file mode 100644 (file)
index 1d75dec..0000000
Binary files a/deps/common-lisp/clnl-gltk_0.1.tar.gz and /dev/null differ

diff --git a/deps/common-lisp/clnl-gltk_0.2.tar.gz b/deps/common-lisp/clnl-gltk_0.2.tar.gz
new file mode 100644 (file)
index 0000000..95489e2
Binary files /dev/null and b/deps/common-lisp/clnl-gltk_0.2.tar.gz differ

diff --git a/resources/UI-test.nlogo b/resources/UI-test.nlogo
index 51bc13783c95ab2bd41801bbba655929414812bf..5b08fe04f8dce150c66834e1af0c8709a7305d1a 100644 (file)
--- a/resources/UI-test.nlogo
+++ b/resources/UI-test.nlogo
@@ -1,6 +1,12 @@
 to go
   ask turtles [ fd 1 ]
 end
+
+to create-and-move
+  if 40 < count turtles [ stop ]
+  crt 1
+  ask turtles [ fd 1 ]
+end
 @#$#@#$#@
 GRAPHICS-WINDOW
 219
@@ -97,6 +103,23 @@ NIL
 NIL
 1
 
+BUTTON
+66
+276
+161
+309
+stopping
+create-and-move
+T
+1
+T
+OBSERVER
+NIL
+NIL
+NIL
+NIL
+1
+
 @#$#@#$#@
 ## WHAT IS IT?
 

diff --git a/src/main/model.lisp b/src/main/model.lisp
index 3e7c9514705e2abd79832ea7f170c71017f7f9c3..0ab8c101bf190198f7781452d4c92eb3b124fa3a 100644 (file)
--- a/src/main/model.lisp
+++ b/src/main/model.lisp
@@ -308,7 +308,12 @@ DESCRIPTION:
        (loop
         :while (find button *enabled-forever-buttons* :test #'equal)
         ; The sleep is necessary so that it gives other threads time
-        :do (progn (clnl:run-commands (button-code button)) (sleep .001))))
+        :do
+        (let
+         ((result (funcall *current-callback* (button-code button))))
+         (when (eql :stop result)
+          (setf *enabled-forever-buttons* (remove button *enabled-forever-buttons* :test #'equal)))
+         (sleep .001))))
       :name (format nil "Forever button: ~A" (button-display button))))
     (t (funcall *current-callback* (button-code button)))))))
 

diff --git a/src/test/main.lisp b/src/test/main.lisp
index a62cd60f7433abd08019d77e4ee49daf3be7ade2..6d3282d6a28cf22d40368708054c6c5810b909c1 100644 (file)
--- a/src/test/main.lisp
+++ b/src/test/main.lisp
@@ -169,7 +169,15 @@ GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1
 (defmacro defmodelreportertest (name model commands reporter value checksum)
  `(defmodeltest (format nil "Model Reporter - ~A" ,name) ,model ,commands ,reporter ,value ,checksum))
 
-(defmacro defmodelfiletest (name file commands checksum)
+(defun wait-for-forever ()
+ (loop
+  :while
+  (find-if
+   (lambda (name) (cl-ppcre:scan "Forever button:" name))
+   (mapcar #'sb-thread:thread-name (sb-thread:list-all-threads)))
+  :do (sleep .1)))
+
+(defmacro defmodelfiletest (name file commands checksum &optional wait-for-forever)
  `(defsimpletest
    ,(format nil "File Model - ~A" name)
    (lambda ()
@@ -181,6 +189,7 @@ GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1
        (declaim (sb-ext:muffle-conditions cl:warning))
        (eval (clnl:model->single-form-lisp model :netlogo-callback (lambda (f) (setf callback f))))
        (when ,(clnl-commands commands) (funcall callback ,(clnl-commands commands)))
+       ,(when wait-for-forever `(wait-for-forever))
        (checksum= ,checksum (checksum-world)))
       (let*
        ((pkg (make-package (gensym)))
@@ -195,6 +204,7 @@ GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1
        (funcall (symbol-function (intern "BOOT-ME" pkg)))
        (when ,(clnl-commands commands)
         (funcall (symbol-function (intern "NETLOGO-CALLBACK" pkg)) ,(clnl-commands commands)))
+       ,(when wait-for-forever `(wait-for-forever))
        (checksum= ,checksum (checksum-world))))))
    (lambda ()
     (let
@@ -205,6 +215,7 @@ GRAPHICS-WINDOW~%210~%10~%649~%470~%-1~%-1~%13.0~%1~%10~%1~%1~%1~%0~%1~%1~%1~%-1
        (with-open-file (str ,file) (clnl-model:read-from-nlogo str))
        :netlogo-callback (lambda (f) (setf callback f))))
      (when ,(clnl-commands commands) (funcall callback ,(clnl-commands commands)))
+     ,(when wait-for-forever `(wait-for-forever))
      (format nil "~A~A"
       (clnl-nvm:export-world)
       (checksum-world))))

diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp
index 133827d4f2d1d0ef4a38f07f28f3aa21d9faff17..d80f871bbf201881b68945a75d2ffb94f6467b48 100644 (file)
--- a/src/test/modeltests.lisp
+++ b/src/test/modeltests.lisp
@@ -139,6 +139,11 @@ end"
  (":button \"setup\" :button \"go\" 1" "crt 10 go ask turtles [ rt 90 ] go")
  "4E0128F172B4D0085186E49FDBD7014F6E365ED7")
 
+(defmodelfiletest "UI 4" "resources/UI-test.nlogo"
+ (":button \"stopping\"" "repeat 80 [ create-and-move ]")
+ "749DC971517EDE9020BF125D0F362A978980272F"
+ t)
+
 (defmodelfiletest "Wolf Sheep 1" "resources/models/Wolf Sheep Predation.nlogo"
  "setup go go go go go go go go go go go go go go"
  "9777CCF18935E52D8380C9C6DC02BFFBEE1F1149")