(defvar *patch-list* nil)
(defvar *glut-window-opened* nil)
-(defvar *dimensions* nil)
+(defvar *dimensions* nil) ; This is a useful placeholder for other view properties
(defvar *window-width* 1024)
(defvar *window-height* 768)
(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
+; the interface state. We keep it seperate from the main system display thread for two reasons:
+; 1) It should run even if there's no active display
+; 2) We want it to run slower than the current display thread
+(defvar *interface-thread* nil)
+
+(defgeneric update-widget (type def widget extra-info))
+(defmethod update-widget (type def widget extra-info))
+
+(defmethod update-widget ((type (eql :button)) button-def button idx)
+ (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))
+ *widgets*))
+
+(defun boot-interface-thread ()
+ (when (not *interface-thread*)
+ (setf *interface-thread*
+ (sb-thread:make-thread (lambda () (loop (update-interface) (sleep .1))) :name "Interface Thread"))))
+
; For now, shapes can live in here
; header is
; * name <like default>
(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
(defun render-widgets ()
(clnl-gltk:render *textbox*)
- (clnl-gltk:render *inputbox*))
+ (clnl-gltk:render *inputbox*)
+ (mapcar #'clnl-gltk:render (mapcar #'third *widgets*)))
(defun render ()
(gl:clear :color-buffer-bit :depth-buffer-bit)
(gl:viewport 0 0 *window-width* *window-height*)
(gl:matrix-mode :projection)
- (gl:with-pushed-matrix
- (gl:load-identity)
- (gl:ortho 0 *window-width* 0 *window-height* 0 5000)
- (render-widgets)
+ (let*
+ ((left (getf *dimensions* :left))
+ (top (getf *dimensions* :top))
+ (view-x1 left)
+ (view-x2 (+ view-x1 width))
+ (view-y1 (- *window-height* height top))
+ (view-y2 (- *window-height* top)))
- (gl:begin :lines)
- (gl:vertex (- *window-width* width 10) (- *window-height* height 10))
- (gl:vertex (- *window-width* width 10) (- *window-height* 9))
+ (gl:with-pushed-matrix
+ (gl:load-identity)
+ (gl:ortho 0 *window-width* 0 *window-height* 0 5000)
+ (render-widgets)
- (gl:vertex (- *window-width* width 10) (- *window-height* 9))
- (gl:vertex (- *window-width* 9) (- *window-height* 9))
+ (gl:color 1 1 1)
+ (gl:begin :lines)
+ (gl:vertex view-x1 view-y1)
+ (gl:vertex view-x1 (+ view-y2 1))
- (gl:vertex (- *window-width* 9) (- *window-height* 9))
- (gl:vertex (- *window-width* 9) (- *window-height* height 10))
+ (gl:vertex view-x1 (+ view-y2 1))
+ (gl:vertex (+ view-x2 1) (+ view-y2 1))
- (gl:vertex (- *window-width* 9) (- *window-height* height 10))
- (gl:vertex (- *window-width* width 10) (- *window-height* height 10))
- (gl:end))
+ (gl:vertex (+ view-x2 1) (+ view-y2 1))
+ (gl:vertex (+ view-x2 1) (- view-y1 1))
- (gl:viewport (- *window-width* width 10) (- *window-height* height 10) width height)
- (render-scene)))
+ (gl:vertex (+ view-x2 1) view-y1)
+ (gl:vertex (- view-x1 1) view-y1)
+ (gl:end))
+
+ (gl:viewport view-x1 view-y1 width height)
+ (render-scene))))
(defun display ()
(render)
(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 (widget)
+ (clnl-gltk:reposition (third widget)
+ (getf (second widget) :left)
+ (- *window-height* (getf (second widget) :height) (getf (second widget) :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 #'third *widgets*)))
+
+(defun motion (x y)
+ (mapcar
+ (lambda (w) (clnl-gltk:mousemove w x (- *window-height* y)))
+ (mapcar #'third *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
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 button-defs->buttons (button-defs)
+ (let
+ ((known-button-names nil))
+ (mapcar
+ (lambda (button-def)
+ (let*
+ ((idx (length (remove (getf button-def :display) known-button-names :test-not #'equal)))
+ (toggle-button nil)
+ (button
+ (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 ()
+ (when toggle-button (funcall toggle-button))
+ (execute
+ (format nil ":button \"~A\"~A"
+ (getf button-def :display)
+ (if (zerop idx) "" (format nil " ~A" idx)))))
+ :forever (getf button-def :forever))))
+ (push (getf button-def :display) known-button-names)
+ (when (getf button-def :forever) (setf toggle-button (lambda () (clnl-gltk:toggle button))))
+ (list :button button-def button idx)))
+ button-defs)))
+
+(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 slider-defs->sliders (slider-defs)
+ (mapcar
+ (lambda (slider-def)
+ (let*
+ ((slider
+ (clnl-gltk:slider
+ (getf slider-def :left)
+ (- *window-height* clnl-gltk:*slider-height* (getf slider-def :top))
+ (getf slider-def :width)
+ (getf slider-def :display)
+ (lambda (state) (execute (format nil "set ~A ~A" (getf slider-def :display) state)))
+ (read-from-string (getf slider-def :min))
+ (read-from-string (getf slider-def :max))
+ (read-from-string (getf slider-def :step))
+ (getf slider-def :initial-value))))
+ (list :slider (append slider-def (list :height clnl-gltk:*slider-height*)) slider nil)))
+ slider-defs))
+
+(defun textbox-defs->textboxes (textbox-defs)
+ (mapcar
+ (lambda (textbox-def)
+ (let*
+ ; we adjust to make it match jvm netlogo more accurately because
+ ; of what we do with width/height (in terms of characters)
+ ((adjusted-top (+ (getf textbox-def :top) 3))
+ (adjusted-left (- (getf textbox-def :left) 3))
+ (textbox
+ (clnl-gltk:textbox
+ adjusted-left
+ (- *window-height* (* (getf textbox-def :height) clnl-gltk:*font-height*) adjusted-top)
+ (getf textbox-def :width)
+ (getf textbox-def :height)
+ :text (getf textbox-def :display)
+ :border nil
+ :word-wrap t)))
+ (list
+ :textbox
+ (append
+ (list
+ :left adjusted-left
+ :top adjusted-top
+ :height (* (getf textbox-def :height) clnl-gltk:*font-height*))
+ textbox-def)
+ textbox nil)))
+ textbox-defs))
+
+(defun initialize (&key dims view buttons switches sliders textboxes)
+ "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:
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
+ WIDTH: An integer representing width
+ VAR: A string representing the variable name
+ DISPLAY: A string representing display name
+ INITIAL-VALUE: The initial value
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))
+ (boot-interface-thread)
+ (setf *dimensions* (append dims view))
+ (setf *widgets*
+ (append
+ (button-defs->buttons buttons)
+ (textbox-defs->textboxes textboxes)
+ (switch-defs->switches switches)
+ (slider-defs->sliders sliders))))
(defun run ()
"RUN => RESULT
(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)
(clnl-gltk:textbox
5 (+ clnl-gltk:*font-height* 14)
10 12
- (format nil *initial-banner* (asdf:component-version (asdf:find-system :clnl)))))
+ :text (format nil *initial-banner* (asdf:component-version (asdf:find-system :clnl)))))
(setf *inputbox* (clnl-gltk:inputbox 5 5 10))
(cl-glut:main-loop)))
projects / clnl / blobdiff