From 5f87a9fd0bed8832115f11073e5ee9a968ee95c0 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Thu, 10 Aug 2017 05:07:09 -0500 Subject: [PATCH] UI/Model Parse - Switches --- resources/UI-test.nlogo | 13 ++++++++++++- src/main/interface.lisp | 41 ++++++++++++++++++++++++++++++++++------ src/main/main.lisp | 6 ++++-- src/main/model.lisp | 34 +++++++++++++++++++++++++++++++++ src/main/nvm/nvm.lisp | 8 +++++++- src/main/package.lisp | 2 +- src/main/parse.lisp | 4 ++++ src/main/transpile.lisp | 4 ++++ src/test/modeltests.lisp | 17 +++++++++-------- 9 files changed, 110 insertions(+), 19 deletions(-) diff --git a/resources/UI-test.nlogo b/resources/UI-test.nlogo index 5b08fe0..b7eed22 100644 --- a/resources/UI-test.nlogo +++ b/resources/UI-test.nlogo @@ -41,7 +41,7 @@ BUTTON 102 61 setup -crt 10 +crt 10 [ if new-turtles-green [ set color green ] ] NIL 1 T @@ -120,6 +120,17 @@ NIL NIL 1 +SWITCH +13 +127 +198 +160 +new-turtles-green +new-turtles-green +1 +1 +-1000 + @#$#@#$#@ ## WHAT IS IT? diff --git a/src/main/interface.lisp b/src/main/interface.lisp index b9e8e68..6d2ae37 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -13,6 +13,8 @@ (defvar *textbox* nil) (defvar *inputbox* nil) +(defvar *current-globals* nil) + (defvar *widgets* nil) ; this is going to be pairs to save the original definition ; This is the thread that does the work of querying the currently running system to update @@ -28,6 +30,11 @@ (when (getf button-def :forever) (clnl-gltk:toggle button (clnl-model:forever-button-on (getf button-def :display) idx)))) +(defmethod update-widget ((type (eql :switch)) switch-def switch nothing) + (let + ((global (find (getf switch-def :var) *current-globals* :key (lambda (def) (getf def :name))))) + (clnl-gltk:toggle switch (getf global :value)))) + (defun update-interface () (mapcar (lambda (widget) (apply #'update-widget widget)) @@ -256,7 +263,8 @@ (gl:matrix-mode :modelview) (gl:with-pushed-matrix (gl:load-identity) - (destructuring-bind (turtles patches) (clnl-nvm:current-state) + (destructuring-bind (turtles patches globals) (clnl-nvm:current-state) + (setf *current-globals* globals) (mapcar (lambda (patch) (let @@ -473,13 +481,30 @@ keep apprised of any updates that may happen.") (list :button button-def button idx))) button-defs))) -(defun initialize (&key dims view buttons) - "INITIALIZE &key DIMS VIEW BUTTONS => RESULT +(defun switch-defs->switches (switch-defs) + (mapcar + (lambda (switch-def) + (let* + ((switch + (clnl-gltk:switch + (getf switch-def :left) + (- *window-height* clnl-gltk:*switch-height* (getf switch-def :top)) + (getf switch-def :width) + (getf switch-def :display) + (lambda (state) (execute (format nil "set ~A ~A" (getf switch-def :display) (if state "true" "false")))) + (getf switch-def :initial-value)))) + (list :switch (append switch-def (list :height clnl-gltk:*switch-height*)) switch nil))) + switch-defs)) + +(defun initialize (&key dims view buttons switches) + "INITIALIZE &key DIMS VIEW BUTTONS SWITCHES => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE) VIEW: (:left LEFT :top TOP) BUTTONS: BUTTON-DEF* + SWITCHES: SWITCH-DEF* BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :forever FOREVER :display DISPLAY) + SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE) ARGUMENTS AND VALUES: @@ -489,12 +514,14 @@ ARGUMENTS AND VALUES: YMIN: An integer representing the minimum patch coord in Y YMAX: An integer representing the maximum patch coord in Y PATCH-SIZE: A double representing the size of the patches in pixels + HEIGHT: An integer representing height + FOREVER: A boolean representing the forever status LEFT: An integer representing the left position TOP: An integer representing the top position - HEIGHT: An integer representing height WIDTH: An integer representing width - FOREVER: A boolean representing the forever status + VAR: A string representing the variable name DISPLAY: A string representing display name + INITIAL-VALUE: The initial value DESCRIPTION: @@ -505,7 +532,9 @@ DESCRIPTION: (boot-interface-thread) (setf *dimensions* (append dims view)) (setf *widgets* - (button-defs->buttons buttons))) + (append + (button-defs->buttons buttons) + (switch-defs->switches switches)))) (defun run () "RUN => RESULT diff --git a/src/main/main.lisp b/src/main/main.lisp index d1ffdad..4b845cf 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -223,7 +223,8 @@ EXAMPLES: `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model) :view ',(clnl-model:view model) - :buttons ',(clnl-model:buttons model))))))))) + :buttons ',(clnl-model:buttons model) + :switches ',(clnl-model:switches model))))))))) (setf (documentation 'model->single-form-lisp 'function) "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM @@ -278,7 +279,8 @@ DESCRIPTION: `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model) :view ',(clnl-model:view model) - :buttons ',(clnl-model:buttons model))))) + :buttons ',(clnl-model:buttons model) + :switches ',(clnl-model:switches model))))) ,@(when netlogo-callback-fn `((defun ,netlogo-callback-fn (,(intern "NETLOGO-CODE" *model-package*)) ,(netlogo-callback-body prims)))))))) diff --git a/src/main/model.lisp b/src/main/model.lisp index 0ab8c10..c947987 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -425,6 +425,40 @@ DESCRIPTION: :display (button-display-name widget))))) (model-interface model)))) +(defun switches (model) + "SWITCHES MODEL => SWITCH-DEFS + + SWITCH-DEFS: SWITCH-DEF* + SWITCH-DEF: (:left LEFT :top TOP :width WIDTH :var VAR :display DISPLAY :initial-value INITIAL-VALUE) + +ARGUMENTS AND VALUES: + + MODEL: A valid model + LEFT: An integer representing the left position + TOP: An integer representing the top position + WIDTH: An integer representing width + VAR: A symbole representing variable + DISPLAY: A string representing variable name + INITIAL-VALUE: The initial value + +DESCRIPTION: + + Returns switch definitions that get declared in the switches of the + MODEL. This is used to initialize the interface." + (remove nil + (mapcar + (lambda (widget) + (typecase widget + (switch + (list + :left (switch-left widget) + :top (switch-top widget) + :width (- (switch-right widget) (switch-left widget)) + :var (intern (string-upcase (switch-varname widget)) :keyword) + :display (switch-varname widget) + :initial-value (switch-on widget) )))) + (model-interface model)))) + (defun view (model) "VIEW MODEL => VIEW-DEF diff --git a/src/main/nvm/nvm.lisp b/src/main/nvm/nvm.lisp index e3f582d..96d5789 100644 --- a/src/main/nvm/nvm.lisp +++ b/src/main/nvm/nvm.lisp @@ -153,7 +153,13 @@ DESCRIPTION: :color (patch-color patch) :xcor (patch-xcor patch) :ycor (patch-ycor patch))) - *patches*))) + *patches*) + (mapcar + (lambda (global) + (list + :name (car global) + :value (funcall (cadr global)))) + *globals*))) ; These match netlogo's dump (defgeneric dump-object (o)) diff --git a/src/main/package.lisp b/src/main/package.lisp index 9f35592..c21d38e 100644 --- a/src/main/package.lisp +++ b/src/main/package.lisp @@ -87,7 +87,7 @@ components.")) (:use :common-lisp) (:export #:execute-button #:default-model #:read-from-nlogo #:world-dimensions #:widget-globals #:code - #:buttons #:forever-button-on #:view #:interface #:set-current-interface #:set-callback) + #:buttons #:forever-button-on #:switches #:view #:interface #:set-current-interface #:set-callback) (:documentation "CLNL Model diff --git a/src/main/parse.lisp b/src/main/parse.lisp index 4a0ddeb..4f331ca 100644 --- a/src/main/parse.lisp +++ b/src/main/parse.lisp @@ -379,6 +379,10 @@ DESCRIPTION: (defprim :green () 10) (defprim :white () 10) +; booleans +(defprim :true () 10) +(defprim :false () 10) + (defstructureprim :globals) (defstructureprim :breed) (defstructureprim :turtles-own) diff --git a/src/main/transpile.lisp b/src/main/transpile.lisp index 4ab7559..b0f90fe 100644 --- a/src/main/transpile.lisp +++ b/src/main/transpile.lisp @@ -291,3 +291,7 @@ DESCRIPTION: (defcolorprim :brown) (defcolorprim :green) (defcolorprim :white) + +; Boleans +(defprim :true :reporter (lambda () t)) +(defprim :false :reporter (lambda () nil)) diff --git a/src/test/modeltests.lisp b/src/test/modeltests.lisp index d80f871..9f1c4b0 100644 --- a/src/test/modeltests.lisp +++ b/src/test/modeltests.lisp @@ -125,23 +125,24 @@ end" (defmodelfiletest "UI 0" "resources/UI-test.nlogo" "go" - "793CA6F4AB144780D5139BC01B47BBFCE898576F") + "A0B7B1A12349BA4587A09099B119D96924C924A2") (defmodelfiletest "UI 1" "resources/UI-test.nlogo" - (":button \"setup\"" "crt 10") - "1825131B956968564A55F703E1031EB4A72DE35F") + (":button \"setup\"" "crt 10 [ if new-turtles-green [ set color green ] ]") + "970F510CDECEA8433FDEA3D2F6E90AA70335B06A") (defmodelfiletest "UI 2" "resources/UI-test.nlogo" - (":button \"setup\" :button \"go\"" "crt 10 go") - "686956AD49E1924F6429502FDF1B9C92DAE5E5F8") + (":button \"setup\" :button \"go\"" "crt 10 [ if new-turtles-green [ set color green ] ] go") + "0270BE659387CBB71AB73D23100F41238430D10F") (defmodelfiletest "UI 3" "resources/UI-test.nlogo" - (":button \"setup\" :button \"go\" 1" "crt 10 go ask turtles [ rt 90 ] go") - "4E0128F172B4D0085186E49FDBD7014F6E365ED7") + (":button \"setup\" :button \"go\" 1" + "crt 10 [ if new-turtles-green [ set color green ] ] go ask turtles [ rt 90 ] go") + "35CB38ED652CAEA88FC84D952386A10620BB9CE5") (defmodelfiletest "UI 4" "resources/UI-test.nlogo" (":button \"stopping\"" "repeat 80 [ create-and-move ]") - "749DC971517EDE9020BF125D0F362A978980272F" + "C4A9DD22E8FC16BA503C9F8EDD92962E8D707165" t) (defmodelfiletest "Wolf Sheep 1" "resources/models/Wolf Sheep Predation.nlogo" -- 2.25.1