LMFL#!C(:PADDED T :HOST "SYS" :BACKUP-DATE 2773681948. :SYSTEM-TYPE :LOGICAL :VERSION 3. :TYPE "LISP" :NAME "ARROW-PANES" :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 2769781747. :AUTHOR "REL3-2" :LENGTH-IN-BYTES 6776. :LENGTH-IN-BLOCKS 7. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; -*- Mode:Common-Lisp; Package:COLOR; Base:10 -*-;;; (C) Texas Instruments May 1987;;; ---------------------------------------------;;;                   UP ARROWS;;; ---------------------------------------------(DEFFLAVOR up-arrow-pane ()                      (basic-color-pane    w:stream-mixin    w:graphics-mixin)  (:documentation :combination)  (:default-init-plist    :blinker-p nil    :borders 1    :label nil    ))(DEFMETHOD (up-arrow-pane :after :init) (ignore)                  "Initialize the model pointers for up-arrow panes"  (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-up-arrow (SEND parent :column1)) self))      (2 (SETF (column-up-arrow (SEND parent :column2)) self))      (3 (SETF (column-up-arrow (SEND parent :column3)) self)))))(defmethod (up-arrow-pane :after :refresh) (&rest ignore)    (send self :draw-up-arrow))(DEFMETHOD (up-arrow-pane :who-line-documentation-string) ()  '(:MOUSE-ANY    "Increment the value in this column   "    :MOUSE-L-HOLD "Continuously increment the value in this column  "    :NO-COMMA " ")) (DEFMETHOD (up-arrow-pane :mouse-click) (ignore ignore ignore)  (LET* ((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)))) (delta (IF (= pane-range 1.0) 0.01 1.0)))     (COND ((= (w:mouse-buttons) 1)   ;left-hold increments continuously    (LOOP WHILE (= (w:mouse-buttons) 1) DO (LET* ((readout-position (case col-num       (1 (send parent :readout1))       (2 (send parent :readout2))       (3 (send parent :readout3))))   (new-val (min pane-range (+ readout-position delta))))      (SEND parent :update-current-column new-val column))))  (T   ;any single click increments by 1 or .01   (LET* ((readout-position (case col-num      (1 (send parent :readout1))      (2 (send parent :readout2))      (3 (send parent :readout3))))  (new-val (min pane-range (+ readout-position delta))))     (SEND parent :update-current-column new-val column))))));;; Up arrows are drawn like this:        ;;;;;;              7;;;;;;;;;          1 2   5 6;;;;;;            3   4;;;(DEFMETHOD (up-arrow-pane :draw-up-arrow) ()      (LET* ((w (send self :inside-width)) (h (send self :inside-height)) (x-centering-factor (send self :left-margin-size)) (tri-left-x (round w 6)) (tri-right-x (- w tri-left-x)) (tri-top-x (round w 2)) (tri-top-y (round h 8)) (tri-bot-y (round (* .55 h))) (rect-left-x (round (* .35 w))) (rect-right-x (- w rect-left-x)) (rect-bot-y (round (- h (/ h 10)))) (x1 (+ x-centering-factor tri-left-x)) (y1 tri-bot-y) (x2 (+ x-centering-factor rect-left-x)) (y2 y1) (x3 x2) (y3 rect-bot-y) (x4 (+ x-centering-factor rect-right-x)) (y4 y3) (x5 x4) (y5 y1) (x6 (+ x-centering-factor tri-right-x)) (y6 y1) (x7 (+ x-centering-factor tri-top-x)) (y7 tri-top-y))    (SEND self :expose)    (send self :draw-filled-polygon  x7 y7  `#(,x1 ,x2 ,x3 ,x4 ,x5 ,x6 ,x7 ,x1)  `#(,y1 ,y2 ,y3 ,y4 ,y5 ,y6 ,y7 ,y1)  w:black)));;; ---------------------------------------------;;;                   DOWN ARROWS;;; ---------------------------------------------(DEFFLAVOR down-arrow-pane ()                    (basic-color-pane    w:stream-mixin    w:graphics-mixin)  (:documentation :combination)  (:default-init-plist    :blinker-p nil    :borders 1    :label nil    ))(DEFMETHOD (down-arrow-pane :after :init) (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-down-arrow (SEND parent :column1)) self))      (2 (SETF (column-down-arrow (SEND parent :column2)) self))      (3 (SETF (column-down-arrow (SEND parent :column3)) self)))))(defmethod (down-arrow-pane :after :refresh) (&rest ignore)   (send self :draw-down-arrow))(DEFMETHOD (down-arrow-pane :who-line-documentation-string) ()  '(:MOUSE-ANY    "Decrement the value in this column   "    :MOUSE-L-HOLD "Continuously decrement the value in this column  "    :NO-COMMA " "))(DEFMETHOD (down-arrow-pane :mouse-click) (ignore ignore ignore)  (LET* ((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)))) (delta (IF (= pane-range 1.0) 0.01 1.0)))     (COND ((= (w:mouse-buttons) 1)   ;left-hold decrements continuously    (LOOP WHILE (= (w:mouse-buttons) 1) DO (LET* ((readout-position (case col-num       (1 (send parent :readout1))       (2 (send parent :readout2))       (3 (send parent :readout3))))   (new-val (max 0 (- readout-position delta))))      (SEND parent :update-current-column new-val column))))  (T   ;any single click decrements by 1 or .01   (LET* ((readout-position (case col-num      (1 (send parent :readout1))      (2 (send parent :readout2))      (3 (send parent :readout3))))  (new-val (max 0 (- readout-position delta))))     (SEND parent :update-current-column new-val column))))));;; Down arrows are drawn like this:        ;;; (pts. #1 & #8 coincide);;;;;;            3   4;;;;;;          1 2   5 6;;;;;;;;;              7;;;(DEFMETHOD (down-arrow-pane :draw-down-arrow) ()     (LET* ((w (send self :inside-width)) (h (send self :inside-height)) (x-centering-factor (send self :left-margin-size)) (y-centering-factor (send self :top-margin-size)) (tri-left-x (round w 6)) (tri-right-x (- w tri-left-x)) (tri-bot-x (round w 2)) (tri-bot-y (- h (round h 8))) (tri-top-y (round (* .45 h))) (rect-left-x (round (* .35 w))) (rect-right-x (- w rect-left-x)) (rect-top-y (round h 10)) (x1 (+ x-centering-factor tri-left-x)) (y1 (+ y-centering-factor tri-top-y)) (x2 (+ x-centering-factor rect-left-x)) (y2 y1) (x3 x2) (y3 (+ y-centering-factor rect-top-y)) (x4 (+ x-centering-factor rect-right-x)) (y4 y3) (x5 x4) (y5 y1) (x6 (+ x-centering-factor tri-right-x)) (y6 y1) (x7 (+ x-centering-factor tri-bot-x)) (y7 (+ y-centering-factor tri-bot-y)))    (SEND self :expose)    (send self :draw-filled-polygon  x7 y7  `#(,x1 ,x2 ,x3 ,x4 ,x5 ,x6 ,x7 ,x1)  `#(,y1 ,y2 ,y3 ,y4 ,y5 ,y6 ,y7 ,y1)  w:black)))(COMPILE-FLAVOR-METHODS up-arrow-pane down-arrow-pane)