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