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

   1 (in-package #:clnl-gltk)
   2
   3 ; some notes:
   4 ; - check logic when min is greater than max
   5 ; - check logic when value is outside of bounds
   6 ;   - should make the handle disappear
   7 ; - check logic when min or max updates
   8
   9 ; - have a hover for handle, when mousedown, do mousedown like the others
  10 ; - have a hover for the bar
  11
  12 ; - handle "Units" from netlogo sliders
  13 ; - have display be dependent on significant digits of min/max/step
  14
  15 ; - handle vertical sliders - this is really just the same slider just rotated, nothing special
  16
  17 ; Height is constant for slideres in netlogo
  18 (defvar *slider-height* 33
  19  "*SLIDER-HEIGHT*
  20
  21 VALUE TYPE:
  22
  23   an integer
  24
  25 INITIAL VALUE:
  26
  27   33
  28
  29 DESCRIPTION:
  30
  31   The default slider height.")
  32
  33 (defstruct slider x y width text callback min max increment value dragging)
  34
  35 (defun slider (x y width text callback min max increment value)
  36  "SLIDER X Y WIDTH TEXT CALLBACK MIN MAX INCREMENT VALUE => SLIDER
  37
  38 ARGUMENTS AND VALUES:
  39
  40   X: x offset, in pixels
  41   Y: y offset, in pixels
  42   WIDTH: width, in pixels
  43   TEXT: string for the textual display
  44   CALLBACK: a function
  45   MIN: minimum value
  46   MAX: maximum value
  47   INCREMENT: increment when moving the slider
  48   VALUE: inital value
  49   SLIDER: a slider that can later be rendered
  50
  51 DESCRIPTION:
  52
  53   SLIDER creates a button widget.
  54
  55   TODO: The rest of this description needs to be updated!"
  56  (make-slider
  57   :x x :y y :width width :text text :callback callback
  58   :min min :max max :value value :increment increment :dragging nil))
  59
  60 (defun slider-bar-left (slider)
  61  (with-slots (min max value width) slider
  62   (+ 4 (if (and value min max (/= min max)) (floor (* (- width 12) (/ value (- max min)))) 0))))
  63
  64 (defun set-min (slider min)
  65  (setf (slider-min slider) min))
  66
  67 (defun set-max (slider max)
  68  (setf (slider-max slider) max))
  69
  70 (defun set-value (slider value)
  71  (setf (slider-value slider) value))
  72
  73 (defun update-slider-value-from-click (slider x)
  74  (if
  75   (< x (+ (slider-x slider) (slider-bar-left slider)))
  76   (setf (slider-value slider) (max (slider-min slider) (- (slider-value slider) (slider-increment slider))))
  77   (setf (slider-value slider) (min (slider-max slider) (+ (slider-value slider) (slider-increment slider))))))
  78
  79 (defun update-slider-value-from-move (slider m-x)
  80  (with-slots (x width value min max increment) slider
  81   (let*
  82    ((left (+ x 4))
  83     (right (+ x width -8))
  84     (portion-left (/ (- m-x left) (- right left)))
  85     (new-value
  86      (max min
  87       (min max
  88        (+ min
  89         (* increment
  90          (floor
  91           (* portion-left (- max min))
  92           increment)))))))
  93    (when (/= value new-value)
  94     (setf (slider-value slider) new-value)))))
  95
  96 (defun in-slider (m-x m-y slider)
  97  (with-slots (x y width) slider
  98   (and (< x m-x (+ x width)) (< y m-y (+ y *slider-height*)))))
  99
 100 (defun in-slider-handle (m-x m-y slider)
 101  (and
 102   (in-slider-bar m-y slider)
 103   (let
 104    ((left (+ (slider-x slider) (slider-bar-left slider))))
 105    (< left m-x (+ left 6)))))
 106
 107 (defun in-slider-bar (m-y slider)
 108  (with-slots (y) slider
 109   (< (+ y 18) m-y (+ y 30))))
 110
 111 ; Uhm, this is currently just pulled from switch, and needs to be changed to slider looking stuffs
 112 (defmethod render ((slider slider))
 113  (gl:color 1f0 1f0 1f0)
 114  (with-slots (x y width text min max value) slider
 115   (gl:with-pushed-matrix
 116    (gl:translate x y 0)
 117
 118    (gl:color 1f0 1f0 1f0)
 119    (gl:begin :quads)
 120    (gl:vertex 3 26) (gl:vertex (- width 5) 26) (gl:vertex (- width 5) 24) (gl:vertex 3 24)
 121    (gl:end)
 122
 123    (let
 124     ((left (slider-bar-left slider)))
 125     (gl:color 0f0 0f0 0f0)
 126     (gl:begin :quads)
 127     (gl:vertex left 30) (gl:vertex (+ left 4) 30) (gl:vertex (+ left 4) 20) (gl:vertex left 20)
 128     (gl:end)
 129     (gl:color 1f0 1f0 1f0)
 130     (draw-border left 20 (+ left 4) 30))
 131
 132    (gl:color 1f0 1f0 1f0)
 133    ;(gl:with-pushed-matrix (gl:translate 14 15 0) (font-print "On"))
 134    ;(gl:with-pushed-matrix (gl:translate 14 1 0) (font-print "Off"))
 135
 136    (draw-border 0 0 width *slider-height*)
 137
 138    ; when the value is large enough, value takes precidence and clips off the text, then makes the text disappear
 139    ; if TOO large!
 140    ;
 141    ; It also clips off text if too long, and replaces with elipses, so we can do similar
 142    ; (this is true for slider and switch!)
 143    ;  - WE HAVEN"T DONE THIS YET
 144    (let
 145     ((text
 146       (if (< (* *font-width* (length text)) (- width 46))
 147        text
 148        (format nil "~A..." (subseq text 0 (- (truncate (- width 46) *font-width*) 3))))))
 149     (gl:with-pushed-matrix
 150      (gl:translate 2 2 0)
 151      (font-print text)))
 152
 153    ; Technically netlogo does not clip numbers that are too large, and just draws what it can.
 154    ; It's a rare edge case, but maybe we should have something to do with it
 155    ;  - WE HAVEN"T DONE THIS YET
 156    (let
 157     ((value-text (format nil "~A" (or value 0))))
 158     (gl:with-pushed-matrix
 159      (gl:translate (- width 4 (* (length value-text) *font-width*)) 2 0)
 160      (font-print value-text))))))
 161
 162 (defmethod reposition ((slider slider) x y)
 163  (setf (slider-x slider) x)
 164  (setf (slider-y slider) y))
 165
 166 (defmethod resize ((slider slider) width height)
 167  (declare (ignore height))
 168  (setf (slider-width slider) width))
 169
 170 (defmethod mousemove ((slider slider) m-x m-y)
 171  (when
 172   (and (slider-dragging slider) (update-slider-value-from-move slider m-x))
 173   (funcall (slider-callback slider) (slider-value slider))))
 174
 175 (defmethod mouseup ((slider slider) m-x m-y)
 176  (when (slider-dragging slider)
 177   (setf (slider-dragging slider) nil)
 178   (funcall (slider-callback slider) (slider-value slider))))
 179
 180 (defmethod mousedown ((slider slider) m-x m-y)
 181  (cond
 182   ((not (in-slider m-x m-y slider)) nil)
 183   ((in-slider-handle m-x m-y slider) (setf (slider-dragging slider) t))
 184
 185   ; Netlogo recognizes the click even if outside the bar horizontally
 186   ((in-slider-bar m-y slider)
 187    (update-slider-value-from-click slider m-x)
 188    (funcall (slider-callback slider) (slider-value slider)))))