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

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