[clnl] / src / main / clnl-gltk / button.lisp

(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))