--- /dev/null
+(in-package #:clnl-gltk)
+
+; some notes:
+; - check logic when min is greater than max
+; - check logic when value is outside of bounds
+; - should make the handle disappear
+; - check logic when min or max updates
+
+; - have a hover for handle, when mousedown, do mousedown like the others
+; - have a hover for the bar
+
+; - handle "Units" from netlogo sliders
+; - have display be dependent on significant digits of min/max/step
+
+; - handle vertical sliders - this is really just the same slider just rotated, nothing special
+
+; Height is constant for slideres in netlogo
+(defvar *slider-height* 33
+ "*SLIDER-HEIGHT*
+
+VALUE TYPE:
+
+ an integer
+
+INITIAL VALUE:
+
+ 33
+
+DESCRIPTION:
+
+ The default slider height.")
+
+(defstruct slider x y width text callback min max increment value dragging)
+
+(defun slider (x y width text callback min max increment value)
+ "SLIDER X Y WIDTH TEXT CALLBACK MIN MAX INCREMENT VALUE => SLIDER
+
+ARGUMENTS AND VALUES:
+
+ X: x offset, in pixels
+ Y: y offset, in pixels
+ WIDTH: width, in pixels
+ TEXT: string for the textual display
+ CALLBACK: a function
+ MIN: minimum value
+ MAX: maximum value
+ INCREMENT: increment when moving the slider
+ VALUE: inital value
+ SLIDER: a slider that can later be rendered
+
+DESCRIPTION:
+
+ SLIDER creates a button widget.
+
+ TODO: The rest of this description needs to be updated!"
+ (make-slider
+ :x x :y y :width width :text text :callback callback
+ :min min :max max :value value :increment increment :dragging nil))
+
+(defun slider-bar-left (slider)
+ (with-slots (min max value width) slider
+ (+ 4 (if (and value min max (/= min max)) (floor (* (- width 12) (/ value (- max min)))) 0))))
+
+(defun set-min (slider min)
+ (setf (slider-min slider) min))
+
+(defun set-max (slider max)
+ (setf (slider-max slider) max))
+
+(defun set-value (slider value)
+ (setf (slider-value slider) value))
+
+(defun update-slider-value-from-click (slider x)
+ (if
+ (< x (+ (slider-x slider) (slider-bar-left slider)))
+ (setf (slider-value slider) (max (slider-min slider) (- (slider-value slider) (slider-increment slider))))
+ (setf (slider-value slider) (min (slider-max slider) (+ (slider-value slider) (slider-increment slider))))))
+
+(defun update-slider-value-from-move (slider m-x)
+ (with-slots (x width value min max increment) slider
+ (let*
+ ((left (+ x 4))
+ (right (+ x width -8))
+ (portion-left (/ (- m-x left) (- right left)))
+ (new-value
+ (max min
+ (min max
+ (+ min
+ (* increment
+ (floor
+ (* portion-left (- max min))
+ increment)))))))
+ (when (/= value new-value)
+ (setf (slider-value slider) new-value)))))
+
+(defun in-slider (m-x m-y slider)
+ (with-slots (x y width) slider
+ (and (< x m-x (+ x width)) (< y m-y (+ y *slider-height*)))))
+
+(defun in-slider-handle (m-x m-y slider)
+ (and
+ (in-slider-bar m-y slider)
+ (let
+ ((left (+ (slider-x slider) (slider-bar-left slider))))
+ (< left m-x (+ left 6)))))
+
+(defun in-slider-bar (m-y slider)
+ (with-slots (y) slider
+ (< (+ y 18) m-y (+ y 30))))
+
+; Uhm, this is currently just pulled from switch, and needs to be changed to slider looking stuffs
+(defmethod render ((slider slider))
+ (gl:color 1f0 1f0 1f0)
+ (with-slots (x y width text min max value) slider
+ (gl:with-pushed-matrix
+ (gl:translate x y 0)
+
+ (gl:color 1f0 1f0 1f0)
+ (gl:begin :quads)
+ (gl:vertex 3 26) (gl:vertex (- width 5) 26) (gl:vertex (- width 5) 24) (gl:vertex 3 24)
+ (gl:end)
+
+ (let
+ ((left (slider-bar-left slider)))
+ (gl:color 0f0 0f0 0f0)
+ (gl:begin :quads)
+ (gl:vertex left 30) (gl:vertex (+ left 4) 30) (gl:vertex (+ left 4) 20) (gl:vertex left 20)
+ (gl:end)
+ (gl:color 1f0 1f0 1f0)
+ (draw-border left 20 (+ left 4) 30))
+
+ (gl:color 1f0 1f0 1f0)
+ ;(gl:with-pushed-matrix (gl:translate 14 15 0) (font-print "On"))
+ ;(gl:with-pushed-matrix (gl:translate 14 1 0) (font-print "Off"))
+
+ (draw-border 0 0 width *slider-height*)
+
+ ; when the value is large enough, value takes precidence and clips off the text, then makes the text disappear
+ ; if TOO large!
+ ;
+ ; It also clips off text if too long, and replaces with elipses, so we can do similar
+ ; (this is true for slider and switch!)
+ ; - WE HAVEN"T DONE THIS YET
+ (let
+ ((text
+ (if (< (* *font-width* (length text)) (- width 46))
+ text
+ (format nil "~A..." (subseq text 0 (- (truncate (- width 46) *font-width*) 3))))))
+ (gl:with-pushed-matrix
+ (gl:translate 2 2 0)
+ (font-print text)))
+
+ ; Technically netlogo does not clip numbers that are too large, and just draws what it can.
+ ; It's a rare edge case, but maybe we should have something to do with it
+ ; - WE HAVEN"T DONE THIS YET
+ (let
+ ((value-text (format nil "~A" (or value 0))))
+ (gl:with-pushed-matrix
+ (gl:translate (- width 4 (* (length value-text) *font-width*)) 2 0)
+ (font-print value-text))))))
+
+(defmethod reposition ((slider slider) x y)
+ (setf (slider-x slider) x)
+ (setf (slider-y slider) y))
+
+(defmethod resize ((slider slider) width height)
+ (declare (ignore height))
+ (setf (slider-width slider) width))
+
+(defmethod mousemove ((slider slider) m-x m-y)
+ (when
+ (and (slider-dragging slider) (update-slider-value-from-move slider m-x))
+ (funcall (slider-callback slider) (slider-value slider))))
+
+(defmethod mouseup ((slider slider) m-x m-y)
+ (when (slider-dragging slider)
+ (setf (slider-dragging slider) nil)
+ (funcall (slider-callback slider) (slider-value slider))))
+
+(defmethod mousedown ((slider slider) m-x m-y)
+ (cond
+ ((not (in-slider m-x m-y slider)) nil)
+ ((in-slider-handle m-x m-y slider) (setf (slider-dragging slider) t))
+
+ ; Netlogo recognizes the click even if outside the bar horizontally
+ ((in-slider-bar m-y slider)
+ (update-slider-value-from-click slider m-x)
+ (funcall (slider-callback slider) (slider-value slider)))))
projects / clnl / blobdiff