--- /dev/null
+(in-package #:clnl-gltk)
+
+(defstruct button x y width height text callback hover click forever toggled)
+
+(defun in-button (m-x m-y but)
+ (with-slots (x y width height) but
+ (and (< x m-x (+ x width)) (< y m-y (+ y height)))))
+
+(defun button (x y width height text callback &key forever)
+ "BUTTON X Y WIDTH HEIGHT TEXT CALLBACK &key FOREVER => BUTTON
+
+ARGUMENTS AND VALUES:
+
+ X: x offset, in pixels
+ Y: y offset, in pixels
+ WIDTH: width, in pixels
+ HEIGHT: height, in pixels
+ TEXT: string for the textual display
+ CALLBACK: a function
+ FOREVER: a boolean, including whether this button is a forever button
+ BUTTON: a button that can later be rendered
+
+DESCRIPTION:
+
+ BUTTON creates a button widget.
+
+ The widget will center the viewable TEXT inside itself, replacing the
+ last three characters with an ellipses if the text is too large for the
+ given dimensions. It will never clip a character.
+
+ BUTTON objects also work with mouse movement functions. When it identifies
+ that a click has happened, CALLBACK will be called.
+
+ When FOREVER is non NIL, an extra icon is added to the button."
+ (make-button :x x :y y :width width :height height :text text :callback callback :forever forever))
+
+; This is just loaded from the forever.dat, which was generated by the forever.png via the command:
+; convert -depth 8 forever.png rgba:forever.dat
+; then generated by this lisp:
+; (with-open-file
+; (str "resources/clnl-gltk/forever.dat" :element-type 'unsigned-byte)
+; (coerce (loop :for b := (read-byte str nil) :while b :collect b) 'vector))
+(defvar *forever-data*
+ #(0 0 0 0 0 0 0 0 255 255 255 10 255 255 255 76 255 255 255 113 255 255 255 76
+ 255 255 255 9 255 255 255 16 255 255 255 11 0 0 0 0 255 255 255 47 255 255
+ 255 217 255 255 255 185 255 255 255 142 255 255 255 186 255 255 255 219 253
+ 253 253 213 255 255 255 28 255 255 255 10 255 255 255 217 255 255 255 91 0 0
+ 0 0 0 0 0 0 255 255 255 16 243 243 243 228 255 255 255 255 255 255 255 36 255
+ 255 255 77 255 255 255 185 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 70 255 255 255
+ 119 255 255 255 219 255 255 255 84 255 255 255 115 255 255 255 140 0 0 0 0 0
+ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 141 255 255 255 114 255 255 255 76
+ 255 255 255 202 255 255 255 68 255 255 255 65 255 255 255 2 0 0 0 0 0 0 0 0
+ 255 255 255 187 255 255 255 75 255 255 255 9 246 246 246 251 254 254 254 254
+ 255 255 255 92 0 0 0 0 0 0 0 0 255 255 255 93 255 255 255 216 255 255 255 9 0
+ 0 0 0 251 251 251 228 253 253 253 231 255 255 255 186 255 255 255 142 255 255
+ 255 187 255 255 255 216 255 255 255 46 0 0 0 0 0 0 0 0 255 255 255 65 255 255
+ 255 9 255 255 255 75 255 255 255 113 255 255 255 75 255 255 255 9 0 0 0 0 0 0
+ 0 0))
+
+(defvar *forever-texture* nil)
+
+(defun setup-button ()
+ (setf *forever-texture* (first (gl:gen-textures 1)))
+ (gl:bind-texture :texture-2d *forever-texture*)
+ (gl:tex-parameter :texture-2d :texture-mag-filter :linear)
+ (gl:tex-parameter :texture-2d :texture-min-filter :linear)
+ (gl:tex-image-2d :texture-2d 0 :rgba8 9 9 0 :rgba :unsigned-byte *forever-data*))
+
+(defun print-arrows (width toggled)
+ (gl:enable :texture-2d)
+ (gl:bind-texture :texture-2d *forever-texture*)
+ (if toggled (gl:color 0f0 0f0 0f0) (gl:color 1f0 1f0 1f0))
+ (gl:begin :quads)
+ (gl:tex-coord 0d0 1d0)
+ (gl:vertex (- width 13) 4)
+ (gl:tex-coord 1d0 1d0)
+ (gl:vertex (- width 4) 4)
+ (gl:tex-coord 1d0 0d0)
+ (gl:vertex (- width 4) 13)
+ (gl:tex-coord 0d0 0d0)
+ (gl:vertex (- width 13) 13)
+ (gl:end)
+ (gl:disable :texture-2d))
+
+(defmethod render ((but button))
+ (gl:color 1f0 1f0 1f0)
+ (with-slots (x y width height text hover click forever toggled) but
+ (gl:with-pushed-matrix
+ (gl:translate x y 0)
+
+ (when (or hover toggled)
+ (cond
+ ((and hover toggled) (gl:color .7f0 .7f0 .7f0))
+ (hover (gl:color .25f0 .25f0 .25f0))
+ (toggled (gl:color .8f0 .8f0 .8f0)))
+ (gl:begin :quads)
+ (gl:vertex 0 0)
+ (gl:vertex width 0)
+ (gl:vertex width height)
+ (gl:vertex 0 height)
+ (gl:end))
+
+ (when click
+ (gl:color .5f0 .5f0 .5f0)
+ (draw-border 0 0 width height 5f0)
+
+ (gl:color .8f0 .8f0 .8f0)
+ (draw-border 0 0 width height 3f0))
+
+ (gl:color 1f0 1f0 1f0)
+ (draw-border 0 0 width height)
+
+ (when forever (print-arrows width toggled))
+
+ ; NetLogo doesn't allow buttons shorter than a letter, so we can assume that we get that height.
+ ; It also clips off text if too long, and replaces with elipses, so we can do similar
+ (if toggled (gl:color 0f0 0f0 0f0) (gl:color 1f0 1f0 1f0))
+ (let
+ ((text
+ (if (< (* *font-width* (length text)) (- width 4))
+ text
+ (format nil "~A..." (subseq text 0 (- (truncate width *font-width*) 3))))))
+ (gl:translate
+ (truncate (- width 4 (* *font-width* (length text))) 2)
+ (truncate (- height 4 *font-height*) 2)
+ 0)
+ (font-print text)))))
+
+(defmethod toggle ((but button) &optional (state :unused))
+ (setf (button-toggled but) (if (eql state :unused) (not (button-toggled but)) state)))
+
+(defmethod reposition ((but button) x y)
+ (setf (button-x but) x)
+ (setf (button-y but) y))
+
+(defmethod resize ((but button) width height)
+ (setf (button-width but) width)
+ (setf (button-height but) height))
+
+(defmethod mousemove ((but button) m-x m-y)
+ (setf (button-hover but) (in-button m-x m-y but)))
+
+(defmethod mousedown ((but button) m-x m-y)
+ (setf (button-click but) (in-button m-x m-y but)))
+
+(defmethod mouseup ((but button) m-x m-y)
+ (when (and (button-hover but) (button-click but) (button-callback but)) (funcall (button-callback but)))
+ (setf (button-click but) nil))
projects / clnl / blobdiff