UI - Buttons

diff --git a/bin/nl b/bin/nl
index a3de215686f70922563c62868eabc3470c4beb82..1abd5c8391b382b2439f89e29a83dc3c2e515e5b 100755 (executable)
--- 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 b18ca5ae97d561c08d45de769e4228bd77f8c149..330135bc91c5baa4f0ad3848da1980630b15b6f8 100644 (file)
--- 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 <like default>
@@ -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 800c2079069a7ff23d9905090503de9b9ee758c0..f7379786669763f6adc54d22b68a2972526c47cf 100644 (file)
--- 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 f054d4c62b0d7f144be7d9e9f07dc5c8866c6052..f31b182e385e645913c95b015924eb4a62953c7c 100644 (file)
--- 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 f92e9986c8bc285253f8d2850a34307979d357c9..973b5c87ae6f93149c58cf9d0b07eafa1d009f18 100644 (file)
--- 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