code.consxy.com Git - clnl/blob - src/main/clnl-gltk/button.lisp

   1 ; Copyright 2022 Frank Duncan (frank@consxy.com) under AGPL3.  See distributed LICENSE.txt.
   2 (in-package #:clnl-gltk)
   3
   4 (defstruct button x y width height text callback hover click forever toggled)
   5
   6 (defun in-button (m-x m-y but)
   7  (with-slots (x y width height) but
   8   (and (< x m-x (+ x width)) (< y m-y (+ y height)))))
   9
  10 (defun button (x y width height text callback &key forever)
  11  "BUTTON X Y WIDTH HEIGHT TEXT CALLBACK &key FOREVER => BUTTON
  12
  13 ARGUMENTS AND VALUES:
  14
  15   X: x offset, in pixels
  16   Y: y offset, in pixels
  17   WIDTH: width, in pixels
  18   HEIGHT: height, in pixels
  19   TEXT: string for the textual display
  20   CALLBACK: a function
  21   FOREVER: a boolean, including whether this button is a forever button
  22   BUTTON: a button that can later be rendered
  23
  24 DESCRIPTION:
  25
  26   BUTTON creates a button widget.
  27
  28   The widget will center the viewable TEXT inside itself, replacing the
  29   last three characters with an ellipses if the text is too large for the
  30   given dimensions.  It will never clip a character.
  31
  32   BUTTON objects also work with mouse movement functions.  When it identifies
  33   that a click has happened, CALLBACK will be called.
  34
  35   When FOREVER is non NIL, an extra icon is added to the button."
  36  (make-button :x x :y y :width width :height height :text text :callback callback :forever forever))
  37
  38 ; This is just loaded from the forever.dat, which was generated by the forever.png via the command:
  39 ;   convert -depth 8  forever.png rgba:forever.dat
  40 ; then generated by this lisp:
  41 ;   (with-open-file
  42 ;    (str "resources/clnl-gltk/forever.dat" :element-type 'unsigned-byte)
  43 ;    (coerce (loop :for b := (read-byte str nil) :while b :collect b) 'vector))
  44 (defvar *forever-data*
  45  #(0 0 0 0 0 0 0 0 255 255 255 10 255 255 255 76 255 255 255 113 255 255 255 76
  46    255 255 255 9 255 255 255 16 255 255 255 11 0 0 0 0 255 255 255 47 255 255
  47    255 217 255 255 255 185 255 255 255 142 255 255 255 186 255 255 255 219 253
  48    253 253 213 255 255 255 28 255 255 255 10 255 255 255 217 255 255 255 91 0 0
  49    0 0 0 0 0 0 255 255 255 16 243 243 243 228 255 255 255 255 255 255 255 36 255
  50    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
  51    119 255 255 255 219 255 255 255 84 255 255 255 115 255 255 255 140 0 0 0 0 0
  52    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
  53    255 255 255 202 255 255 255 68 255 255 255 65 255 255 255 2 0 0 0 0 0 0 0 0
  54    255 255 255 187 255 255 255 75 255 255 255 9 246 246 246 251 254 254 254 254
  55    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
  56    0 0 0 251 251 251 228 253 253 253 231 255 255 255 186 255 255 255 142 255 255
  57    255 187 255 255 255 216 255 255 255 46 0 0 0 0 0 0 0 0 255 255 255 65 255 255
  58    255 9 255 255 255 75 255 255 255 113 255 255 255 75 255 255 255 9 0 0 0 0 0 0
  59    0 0))
  60
  61 (defvar *forever-texture* nil)
  62
  63 (defun setup-button ()
  64  (setf *forever-texture* (first (gl:gen-textures 1)))
  65  (gl:bind-texture :texture-2d *forever-texture*)
  66  (gl:tex-parameter :texture-2d :texture-mag-filter :linear)
  67  (gl:tex-parameter :texture-2d :texture-min-filter :linear)
  68  (gl:tex-image-2d :texture-2d 0 :rgba8 9 9 0 :rgba :unsigned-byte *forever-data*))
  69
  70 (defun print-arrows (width toggled)
  71  (gl:enable :texture-2d)
  72  (gl:bind-texture :texture-2d *forever-texture*)
  73  (if toggled (gl:color 0f0 0f0 0f0) (gl:color 1f0 1f0 1f0))
  74  (gl:begin :quads)
  75  (gl:tex-coord 0d0 1d0)
  76  (gl:vertex (- width 13) 4)
  77  (gl:tex-coord 1d0 1d0)
  78  (gl:vertex (- width 4) 4)
  79  (gl:tex-coord 1d0 0d0)
  80  (gl:vertex (- width 4) 13)
  81  (gl:tex-coord 0d0 0d0)
  82  (gl:vertex (- width 13) 13)
  83  (gl:end)
  84  (gl:disable :texture-2d))
  85
  86 (defmethod render ((but button))
  87  (gl:color 1f0 1f0 1f0)
  88  (with-slots (x y width height text hover click forever toggled) but
  89   (gl:with-pushed-matrix
  90    (gl:translate x y 0)
  91
  92    (when (or hover toggled)
  93     (cond
  94      ((and hover toggled) (gl:color .7f0 .7f0 .7f0))
  95      (hover (gl:color .25f0 .25f0 .25f0))
  96      (toggled (gl:color .8f0 .8f0 .8f0)))
  97     (gl:begin :quads)
  98     (gl:vertex 0 0)
  99     (gl:vertex width 0)
 100     (gl:vertex width height)
 101     (gl:vertex 0 height)
 102     (gl:end))
 103
 104    (when click
 105     (gl:color .5f0 .5f0 .5f0)
 106     (draw-border 0 0 width height 5f0)
 107
 108     (gl:color .8f0 .8f0 .8f0)
 109     (draw-border 0 0 width height 3f0))
 110
 111    (gl:color 1f0 1f0 1f0)
 112    (draw-border 0 0 width height)
 113
 114    (when forever (print-arrows width toggled))
 115
 116    ; NetLogo doesn't allow buttons shorter than a letter, so we can assume that we get that height.
 117    ; It also clips off text if too long, and replaces with elipses, so we can do similar
 118    (if toggled (gl:color 0f0 0f0 0f0) (gl:color 1f0 1f0 1f0))
 119    (let
 120     ((text
 121       (if (< (* *font-width* (length text)) (- width 4))
 122        text
 123        (format nil "~A..." (subseq text 0 (- (truncate width *font-width*) 3))))))
 124     (gl:translate
 125      (truncate (- width 4 (* *font-width* (length text))) 2)
 126      (truncate (- height 4 *font-height*) 2)
 127      0)
 128     (font-print text)))))
 129
 130 (defmethod toggle ((but button) &optional (state :unused))
 131  (setf (button-toggled but) (if (eql state :unused) (not (button-toggled but)) state)))
 132
 133 (defmethod reposition ((but button) x y)
 134  (setf (button-x but) x)
 135  (setf (button-y but) y))
 136
 137 (defmethod resize ((but button) width height)
 138  (setf (button-width but) width)
 139  (setf (button-height but) height))
 140
 141 (defmethod mousemove ((but button) m-x m-y)
 142  (setf (button-hover but) (in-button m-x m-y but)))
 143
 144 (defmethod mousedown ((but button) m-x m-y)
 145  (setf (button-click but) (in-button m-x m-y but)))
 146
 147 (defmethod mouseup ((but button) m-x m-y)
 148  (when (and (button-hover but) (button-click but) (button-callback but)) (funcall (button-callback but)))
 149  (setf (button-click but) nil))