;;; -*- Mode:LISP; Base:10; Readtable:CL -*- ;;; Flavors and functions that implement 'slider' windows. ;;; Slider windows are a sort of active value hack. ;;; They remember a variable, it's maximum and minimum values, and allow you to ;;; interactively set the value of the variable ... ;;; that variable gets declared special ... ;;; NIC sep 85 (defflavor slider-window ((the-var 'foo) ;The variable this window displays (max 100) ;max value of that variable (used for scaling) (min 0) ;min value of that variable (used for scaling) offset ;width left blank for labels (labels-on-side :right) ;label numeric positions (label-lines-p t) ;add lines at labels box-y-pos) ;last y pos used for the box (tv:window) (:documentation "Slider windows display the value of a global variable and allow you to change it.") :gettable-instance-variables :settable-instance-variables :inittable-instance-variables (:default-init-plist :width 72 :inside-height 150 :save-bits t :deexposed-typeout-action :permit :borders 1 :blinker-p nil :font-map '( fonts:tr8 ;display of variable name fonts:tr8 ;display of variable value fonts:hl6 ;display of labels ) )) (defflavor momentary-slider-window () (slider-window tv:hysteretic-window-mixin) (:documentation "Momentary version of a slider-window.") (:default-init-plist :borders 2)) ;;; set everything up. (defmethod (slider-window :after :init) (ignore) "Sets up the label, after init." (send self :set-the-var the-var)) (defmethod (slider-window :after :change-of-size-or-margins) (&optional &rest ignore) (let ((curfont (aref tv:font-map 2))) (setq offset (max ;(quotient tv:width 4) (send self :string-length (format nil " ~A " min) 0 nil nil curfont) (send self :string-length (format nil " ~A " max) 0 nil nil curfont))) (send self :refresh))) (defmethod (slider-window :pane-size) (width height ignore ignore direction) "Should a constraint frame ask how big we are, let's set everything up before we answer." (let ((wid tv:width) (hei tv:height) ret) (if (eq direction :horizontal) (setf hei height ret wid) (setf wid width ret hei)) (send self :set-size wid hei) ;;;(send self :change-of-size-or-margins) ;;;(setf scale (quotient (float (send self :inside-height)) (- max min))) ;;;(send self :set-the-var the-var) ret)) (defmethod (slider-window :add-labels) (&rest nums) "Puts labels on a slider window, at the correct locations. labels-on-side is keyword saying where to put labels. If lines-p is true, will draw a horizontal line at the indicated position, in addition to the label." (let* ((curfont (aref tv:font-map 2)) (charwidth (tv:font-char-width curfont)) (right (- (send self :inside-width) offset)) (y-pos 0) (x-pos (case labels-on-side (:right (+ right charwidth charwidth)) (:left charwidth))) (font-height (tv:font-char-height curfont))) (when (memq labels-on-side '(:right :left)) (dolist (num nums) (setq y-pos (- (send self :win-height-of-num num) tv:top-margin-size)) (send self :string-out-explicit (format nil "~A" num) x-pos y-pos (+ x-pos offset -6) font-height curfont tv:char-aluf) (when label-lines-p (send self :draw-line offset y-pos (- right 1) y-pos tv:alu-xor)))))) (defmethod (slider-window :win-height-of-num) (num) (fixr (+ tv:top-margin-size (* (- 1 (quotient (- num min) (float (- max min)))) (send self :inside-height))))) (defmethod (slider-window :update) () "This is the normal program interface. When a program changes the value of the-var, it should send an :update message to allow the slider window to redisplay its contents." (if (not (= (send self :win-height-of-num (symeval the-var)) box-y-pos)) (send self :box (symeval the-var)))) (defmethod (slider-window :set-the-var) (var) "The-var is the variable we are displaying the value of. This is how it can be changed. In addition, a number of other set-up stuff gets done." (proclaim `(special ,var)) ;declare it special in case it isn't already (or (boundp var) (set var 0)) (setf the-var var) (send self :set-size-in-characters (format nil " ~a " the-var) (second (multiple-value-list (send self :size-in-characters)))) (when (> 72 tv:width) (setf tv:width 72)) ;must always be at least this wide (send self :refresh)) (defmacro limit (low val high) `(max ,low (min ,high ,val))) (defmethod (slider-window :after :refresh) (&rest ignore) (or tv:restored-bits-p ;if it didn't come from a bit-save-array ... (progn (setf box-y-pos (send self :win-height-of-num (limit min 0 max))) (when (boundp the-var) (send self :box (symeval the-var)) (send self :set-label `( :string ,(format nil "~a" the-var) :font ,(aref tv:font-map 0) :centered ) )) (send self :add-labels 25 50 75)))) (defmethod (slider-window :mouse-standard-blinker) () "Changes the mouse blinker to an up-and-down arrow when it is over a slider window." (tv:mouse-set-blinker-definition ':character 4 7 ':on ':set-character 4 'fonts:mouse)) (defmethod (momentary-slider-window :handle-mouse) (&aux width height hysteresis) "Mostly copied from the system source." (let (left-lim top-lim right-lim bottom-lim) (multiple-value (left-lim top-lim) (tv:sheet-calculate-offsets self tv:mouse-sheet)) (setf right-lim (+ left-lim (setf width (send self :width)) (setf hysteresis (send self :hysteresis))) bottom-lim (+ top-lim (setf height (send self :height)) hysteresis) left-lim (- left-lim hysteresis) top-lim (- top-lim hysteresis)) (do (w) (()) ;; let the mouse out of the window only if it moves more than away (and (or tv:mouse-reconsider ;; also leave if mouse fell into inferior (and (neq self (setf w (tv:lowest-sheet-under-point tv:mouse-sheet tv:mouse-x tv:mouse-y nil ':exposed))) (tv:sheet-me-or-my-kid-p w self)) (< tv:mouse-x left-lim) (> tv:mouse-x right-lim) (< tv:mouse-y top-lim) (> tv:mouse-y bottom-lim)) (return t)) (tv:mouse-set-blinker-definition ':character 4 7 ':on ':set-character 4 'fonts:mouse) (tv:mouse-default-handler self (send self ':enable-scrolling-p))))) (defmethod (slider-window :mouse-buttons) (mask x y) "If mouse-left, run the slider function in a separate process. Checks for sysmenu." x y ;never use x or y (if (= mask 1) ;1 means left-mouse and only left-mouse (process-run-function ;do this in a sub-process 'cause we '(:name "slider function" :priority 20.) ;don't wanna muck the mouse process '(lambda (self) (send self :reset-value-with-mouse)) self) (let ((buttons (tv:mouse-button-encode mask))) ;otherwise check for double-click right (if (= buttons #\mouse-3-2) (tv:mouse-call-system-menu) ;and bring up sysmenu (send self :mouse-click buttons x y))))) (defmethod (slider-window :reset-value-with-mouse) () "Waits for the left button to come up, meanwhile looping over calls to tv:mouse-input (i.e. will hang until the mouse moves.) and then drawing a box appropriately, and updating the label. Upon exit, the-var gets set to the new value." (let* ((height (send self :inside-height)) (pos (float (+ (second (multiple-value-list (tv:sheet-calculate-offsets self nil))) (tv:sheet-inside-bottom)))) ;screen coors of inside-bottom (buttons 1) temp) (tv:with-mouse-usurped (setf tv:who-line-mouse-grabbed-documentation "Hold Button down until appropriate value is reached.") (loop while (= 1 buttons) ;1 means mouse-left doing (setf temp (fixr (+ (* (- max min) (quotient (- pos (car (last (multiple-value-list (tv:mouse-input))))) height)) min))) (send self :set-label `(:string ,(format nil "~d" temp) :font ,(aref tv:font-map 1) :centered)) (send self :box temp) (setf buttons (tv:mouse-buttons))) (send self :set-label `(:string ,(eval `(format nil "~a" ',the-var)) :font ,(aref tv:font-map 0) :centered)) (set the-var temp)))) (defmethod (slider-window :box) (num) "Draw a filled-in box on the window representing the current value of the-var. Actually, only draws the difference between the old box and the new one needed, for speed." (let* ((box-num (limit min num max)) (width (+ (- (send self :inside-width) offset offset 2) tv:left-margin-size)) (new-box-y-pos (send self :win-height-of-num box-num))) ; (format ll "box-num: ~A, width: ~A, old,new-y-pos: ~A,~A, size: ~A, start: ~A~%" ; box-num width box-y-pos new-box-y-pos ; (abs (- new-box-y-pos box-y-pos)) (min new-box-y-pos box-y-pos)) (without-interrupts (tv:sheet-is-prepared (self) (si:%draw-rectangle width ;blit the difference onto the screen (abs (- new-box-y-pos box-y-pos)) (+ offset tv:left-margin-size) (min new-box-y-pos box-y-pos) tv:alu-xor self))) (setf box-y-pos new-box-y-pos))) ;set box-y-pos for next time (defmethod (slider-window :who-line-documentation-string) () "Click left and drag to change value.") (defmethod (momentary-slider-window :after :handle-mouse) () "How a momentary slider gets deactivated. See the system source for temp windows." (or ;; don't flush if mouse being usurped tv:window-owning-mouse ;; only flush us if either not explicitly flushing or we don't own mouse (and tv:mouse-reconsider (eq self (tv:window-owning-mouse))) ;; this is called in the mouse process. we don't want to take the chance that ;; we might go blocked, so run in another process. (process-run-function '(:name "slider deactivate" :priority 20.) self ':deactivate))) (tv:defwindow-resource momentary-slider-windows () :make-window (momentary-slider-window) :reusable-when :deexposed) ;;; some test functions (defun slider (var) (let ((slider-win (make-instance 'slider-window))) (send slider-win :set-the-var var) (tv:expose-window-near slider-win '(:mouse)) ;;return the slider created slider-win)) (defun m-slider (var) (let ((slider-win (allocate-resource 'momentary-slider-windows))) (send slider-win :set-the-var var) (tv:expose-window-near slider-win '(:mouse)) ;;return the slider created slider-win)) (compile-flavor-methods slider-window momentary-slider-window)