From 31a8f429b5182d9c4f3eae208ccc8efbdfe8a996 Mon Sep 17 00:00:00 2001 From: Frank Duncan Date: Tue, 11 Jul 2017 21:32:15 -0500 Subject: [PATCH] UI - Buttons --- bin/nl | 2 +- src/main/interface.lisp | 85 ++++++++++++++++++++++++++++++++++------- src/main/main.lisp | 10 ++++- src/main/model.lisp | 32 ++++++++++++++++ src/main/package.lisp | 2 +- 5 files changed, 114 insertions(+), 17 deletions(-) diff --git a/bin/nl b/bin/nl index a3de215..1abd5c8 100755 --- a/bin/nl +++ b/bin/nl @@ -1,6 +1,6 @@ #!/bin/bash -if [ $1 ] ; then +if [ "$1" ] ; then ( cat bin/run.lisp | sed -e '/clnl:run/d' && echo "(clnl:run \"$1\")" ) | sbcl --script else sbcl --script bin/run.lisp diff --git a/src/main/interface.lisp b/src/main/interface.lisp index b18ca5a..330135b 100644 --- a/src/main/interface.lisp +++ b/src/main/interface.lisp @@ -13,6 +13,8 @@ (defvar *textbox* nil) (defvar *inputbox* nil) +(defvar *widgets* nil) ; this is going to be pairs to save the original definition + ; For now, shapes can live in here ; header is ; * name @@ -269,7 +271,8 @@ (defun render-widgets () (clnl-gltk:render *textbox*) - (clnl-gltk:render *inputbox*)) + (clnl-gltk:render *inputbox*) + (mapcar #'clnl-gltk:render (mapcar #'cadr *widgets*))) (defun render () (gl:clear :color-buffer-bit :depth-buffer-bit) @@ -319,30 +322,54 @@ (let ((box-width (truncate (- width 12) clnl-gltk:*font-width*))) (clnl-gltk:resize *textbox* box-width 12) - (clnl-gltk:resize *inputbox* box-width 1)))) + (clnl-gltk:resize *inputbox* box-width 1)) + (mapcar + (lambda (pair) + (clnl-gltk:reposition (cadr pair) + (getf (car pair) :left) + (- *window-height* (getf (car pair) :height) (getf (car pair) :top)))) + *widgets*))) (defun execute (str) - (handler-case - (with-output-to-string (*standard-output*) - (clnl:run-commands str)) - (error (e) (format nil "Ok, something went wrong: ~A~%Try :help" e)))) + (setf + (clnl-gltk:textbox-text *textbox*) + (format nil "> ~A~%~%~A" str + (handler-case + (with-output-to-string (*standard-output*) + (clnl:run-commands str)) + (error (e) (format nil "Ok, something went wrong: ~A~%Try :help" e)))))) (defun key-pressed (key x y) (declare (ignore x y)) (if (eql key 13) - (let* - ((cmd (clnl-gltk:value *inputbox*)) - (resp (execute cmd))) - (setf (clnl-gltk:textbox-text *textbox*) (format nil "> ~A~%~%~A" cmd resp)) + (progn + (execute (clnl-gltk:value *inputbox*)) (clnl-gltk:clear *inputbox*)) (clnl-gltk:key-pressed *inputbox* key))) +(defun mouse (button state x y) + (declare (ignore button)) + (mapcar + (lambda (w) + (when (eql state :down) (clnl-gltk:mousedown w x (- *window-height* y))) + (when (eql state :up) (clnl-gltk:mouseup w x (- *window-height* y)))) + (mapcar #'cadr *widgets*))) + +(defun motion (x y) + (mapcar + (lambda (w) (clnl-gltk:mousemove w x (- *window-height* y))) + (mapcar #'cadr *widgets*))) + (cffi:defcallback display :void () (display)) (cffi:defcallback idle :void () (idle)) (cffi:defcallback close-func :void () (close-func)) (cffi:defcallback reshape :void ((width :int) (height :int)) (reshape width height)) (cffi:defcallback key-pressed :void ((key :uchar) (x :int) (y :int)) (key-pressed key x y)) (cffi:defcallback special-key-pressed :void ((key glut:special-keys) (x :int) (y :int)) (key-pressed key x y)) +(cffi:defcallback mouse :void ((button cl-glut:mouse-button) (state cl-glut:mouse-button-state) (x :int) (y :int)) + (mouse button state x y)) + +(cffi:defcallback motion :void ((x :int) (y :int)) (motion x y)) (defun set-turtle-lists () (setf @@ -387,10 +414,12 @@ You can enter in various netlogo commands below, or use :q to quit the program. See http://github.com/frankduncan/clnl for more information about CLNL and to keep apprised of any updates that may happen.") -(defun initialize (&key dims) - "INITIALIZE &key DIMS => RESULT +(defun initialize (&key dims buttons) + "INITIALIZE &key DIMS BUTTONS => RESULT DIMS: (:xmin XMIN :xmax XMAX :ymin YMIN :ymax YMAX :patch-size PATCH-SIZE) + BUTTONS: BUTTON-DEF* + BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY) ARGUMENTS AND VALUES: @@ -400,6 +429,11 @@ 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 + LEFT: An integer representing the left position + TOP: An integer representing the top position + HEIGHT: An integer representing height + WIDTH: An integer representing width + DISPLAY: A string representing display name DESCRIPTION: @@ -407,7 +441,29 @@ DESCRIPTION: the interface lives. From here, one can go into headless or running mode, but for certain things this interface will still need to act, and also allows for bringing up and taking down of visual elements." - (setf *dimensions* dims)) + (setf *dimensions* dims) + (let + ((known-button-names nil)) + (setf *widgets* + (mapcar + (lambda (button-def) + (let + ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal)))) + (push (getf button-def :display) known-button-names) + (list + button-def + (clnl-gltk:button + (getf button-def :left) + (- *window-height* (getf button-def :height) (getf button-def :top)) + (getf button-def :width) + (getf button-def :height) + (getf button-def :display) + (lambda () + (execute + (format nil ":button \"~A\"~A" + (getf button-def :display) + (if (zerop idx) "" (format nil " ~A" idx))))))))) + buttons)))) (defun run () "RUN => RESULT @@ -438,6 +494,9 @@ DESCRIPTION: (cl-glut:close-func (cffi:get-callback 'close-func)) (cl-glut:keyboard-func (cffi:get-callback 'key-pressed)) (cl-glut:special-func (cffi:get-callback 'special-key-pressed)) + (cl-glut:motion-func (cffi:get-callback 'motion)) ; while mouse is down + (cl-glut:passive-motion-func (cffi:get-callback 'motion)) ; while mouse is up + (cl-glut:mouse-func (cffi:get-callback 'mouse)) ; state is up/down, button is button (gl:depth-func :lequal) (gl:blend-func :src-alpha :one-minus-src-alpha) (gl:enable :blend) diff --git a/src/main/main.lisp b/src/main/main.lisp index 800c207..f737978 100644 --- a/src/main/main.lisp +++ b/src/main/main.lisp @@ -214,7 +214,10 @@ EXAMPLES: `((funcall ,netlogo-callback (lambda (,(intern "NETLOGO-CODE" *model-package*)) ,(netlogo-callback-body prims))))) - ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))))))) + ,@(when initialize-interface + `((clnl-interface:initialize + :dims ',(clnl-model:world-dimensions model) + :buttons ',(clnl-model:buttons model))))))))) (setf (documentation 'model->single-form-lisp 'function) "MODEL->SINGLE-FORM-LISP MODEL &key SEED INITIALIZE-INTERFACE NETLOGO-CALLBACK => FORM @@ -265,7 +268,10 @@ DESCRIPTION: (clnl-model:set-current-interface ',(clnl-model:interface model)) (clnl-model:set-callback (symbol-function ',netlogo-callback-fn)) ,(create-world-call model globals code-ast) - ,@(when initialize-interface `((clnl-interface:initialize :dims ',(clnl-model:world-dimensions model))))) + ,@(when initialize-interface + `((clnl-interface:initialize + :dims ',(clnl-model:world-dimensions model) + :buttons ',(clnl-model:buttons 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 f054d4c..f31b182 100644 --- a/src/main/model.lisp +++ b/src/main/model.lisp @@ -349,6 +349,38 @@ DESCRIPTION: (switch (list (intern (string-upcase (switch-varname widget)) :keyword) (switch-on widget))))) (model-interface model)))) +(defun buttons (model) + "BUTTONS MODEL => BUTTON-DEFS + + BUTTON-DEFS: BUTTON-DEF* + BUTTON-DEF: (:left LEFT :top TOP :height HEIGHT :width WIDTH :display DISPLAY) + +ARGUMENTS AND VALUES: + + MODEL: A valid model + LEFT: An integer representing the left position + TOP: An integer representing the top position + HEIGHT: An integer representing height + WIDTH: An integer representing width + DISPLAY: A string representing display name + +DESCRIPTION: + + Returns button definitions that get declared in the buttons of the + MODEL. This is used to initialize the interface." + (remove nil + (mapcar + (lambda (widget) + (typecase widget + (button + (list + :left (button-left widget) + :top (button-top widget) + :width (- (button-right widget) (button-left widget)) + :height (- (button-bottom widget) (button-top widget)) + :display (button-display-name widget))))) + (model-interface model)))) + (defun code (model) "CODE MODEL => CODE diff --git a/src/main/package.lisp b/src/main/package.lisp index f92e998..973b5c8 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 - #:interface #:set-current-interface #:set-callback) + #:buttons #:interface #:set-current-interface #:set-callback) (:documentation "CLNL Model -- 2.25.1