LMFL#!C(:PADDED T :HOST "SYS" :BACKUP-DATE 2773681995. :SYSTEM-TYPE :LOGICAL :VERSION 8. :TYPE "LISP" :NAME "SLIDE-BARS" :DIRECTORY ("REL3-2" "COLOR-MAP-EDITOR") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-2\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2770661310. :AUTHOR "REL3-2" :LENGTH-IN-BYTES 4037. :LENGTH-IN-BLOCKS 4. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                   ;;; -*- Mode:Common-Lisp; Package:COLOR; Base:10 -*-;;; (C) Texas Instruments May 1987(DEFFLAVOR slide-bar-pane ()   (slide-bar-mixin    basic-color-pane    w:stream-mixin       w:graphics-mixin)  (:documentation :combination)  (:default-init-plist    :blinker-p nil    :label nil)  (:settable-instance-variables))(DEFFLAVOR slide-bar-mixin ()   ()  (:settable-instance-variables)  (:required-flavors basic-color-pane)  (:documentation :mixin))(DEFMETHOD (slide-bar-pane :after :init) (&rest ignore)       (LET ((super (SEND self :superior)))    (case side      (:left (setf parent (SEND super :left-model-instance)))      (:right (setf parent (SEND super :right-model-instance))))    (CASE (column-of-model-column model column)      (1 (SETF (column-slide-bar (SEND parent :column1)) self))      (2 (SETF (column-slide-bar (SEND parent :column2)) self))      (3 (SETF (column-slide-bar (SEND parent :column3)) self)))    (setq current-position (send self :inside-height))))(defmethod (slide-bar-pane :after :refresh) (&rest ignore)  (LET* ((slide-bar-width (send self :inside-width)) (slide-bar-height (send self :inside-height)) (col-num (column-of-model-column model column)) (pane-range (case col-num       (1 (send parent :range1))       (2 (send parent :range2))       (3 (send parent :range3)))) (sbar-factor (/ slide-bar-height pane-range)) (readout-position (case col-num     (1 (send (column-numeric-readout (send parent :column1)) :current-position))     (2 (send (column-numeric-readout (send parent :column2)) :current-position))     (3 (send (column-numeric-readout (send parent :column3)) :current-position)))))    (SEND self :set-current-position (round (- slide-bar-height (* sbar-factor readout-position))))    (SEND self :draw-filled-rectangle   0 current-position  slide-bar-width (- slide-bar-height current-position)  w:white w:alu-seta)))(DEFMETHOD (slide-bar-mixin :who-line-documentation-string) ()  '(:MOUSE-L-1    "Adjust the level in this column to here   "    :MOUSE-L-HOLD "Drag the mouse to adjust the level in this column  "    :NO-COMMA " "))(DEFMETHOD (slide-bar-pane :mouse-moves) (IGNORE y)  (w:mouse-set-blinker-cursorpos)  (COND ((AND (= 1 (tv:mouse-buttons))      (OR (NULL *MOUSE-COLUMN*)  (EQ *MOUSE-COLUMN* COLUMN))) (LET* ((pane-height (SEND self :inside-height))(new-val))   (SETQ *MOUSE-COLUMN* COLUMN)   (SETF current-position y)   (SETQ new-val (* range (- 1.0 (/ y pane-height))))     (SEND parent :update-current-column new-val column)   (w:mouse-set-blinker-cursorpos)))((/= 1 (tv:mouse-buttons)) (SETQ *MOUSE-COLUMN* NIL))))(defmethod (slide-bar-mixin :mouse-click) (ignore ignore ignore)  t)(DEFMETHOD (slide-bar-mixin :redraw-slide-bar) (old-y y)  (LET* ((our-width (SEND self :inside-width)) (y0 old-y) (y1 y) (color (send self :background-color)))    (SEND self :set-current-position (ROUND y1))    ;; erase the old one.    (when (< y1 y0)       (psetq y0 y1 y1 y0)      (setq color w:white))    (SEND self :draw-filled-rectangle 0 (ROUND y0) our-width (ROUND (- (ROUND y1) y0)) color w:alu-seta)))(defmethod (slide-bar-pane :update-slide-bar) (readout)  "update slide bar"  (LET* ((slide-bar-height (send self :inside-height)) (col-num (column-of-model-column model column)) (pane-range (case col-num       (1 (send parent :range1))       (2 (send parent :range2))       (3 (send parent :range3)))) (sbar-factor (/ slide-bar-height pane-range)) (readout-position (case col-num     (1 (send (column-numeric-readout (send parent :column1)) :current-position))     (2 (send (column-numeric-readout (send parent :column2)) :current-position))     (3 (send (column-numeric-readout (send parent :column3)) :current-position)))))    (SEND self :redraw-slide-bar  (- slide-bar-height     (* sbar-factor readout-position))  (- slide-bar-height     (* sbar-factor readout)))))(COMPILE-FLAVOR-METHODS slide-bar-pane)