LMFL#!C(:PADDED T :HOST "SYS" :BACKUP-DATE 2773681963. :SYSTEM-TYPE :LOGICAL :VERSION 12. :TYPE "LISP" :NAME "COLOR-MAP-DISPLAY" :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 2771005674. :AUTHOR "REL3-2" :LENGTH-IN-BYTES 19183. :LENGTH-IN-BLOCKS 19. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;;; -*- Mode:Common-Lisp; Package:COLOR; Base:10; Fonts:(CPTFONT MEDFNB HL12BI MEDFNB)  -*-(DEFFLAVOR menu-pane ()   (w:menu)  (:default-init-plist    :command-menu t    :superior *color-map-selector*    :label '(:string "Color Map Commands" :centered :top :font fonts:tr12b))  (:settable-instance-variables))(DEFMETHOD (menu-pane :after :init) (&rest ignore)  (SEND self :set-io-buffer (SEND (SEND self :superior) :io-buffer)))(DEFFLAVOR index-pane-mixin ()   (w:minimum-window)  (:documentation :combination  "Provides methods to allow us to display our own info in the color index pane."))(DEFMETHOD (index-pane-mixin :after :refresh) (&rest ignore)  (when (and *color-map-selector*     (eq *color-map-selector* superior))    (send superior :display-color-map-name)))(DEFFLAVOR cmd-index-pane ()   (index-pane-mixin w:color-index-pane)  (:default-init-plist      :blinker-p nil    :borders nil))(DEFFLAVOR color-map-frame (message-window    prompt-for-save                 )      (w:inferiors-not-in-select-menu-mixin    ucl:basic-command-loop    w:select-mixin    w:borders-mixin    w:label-mixin    w:box-label-mixin    w:stream-mixin    w:essential-mouse    w:bordered-constraint-frame-with-shared-io-buffer)  (:default-init-plist    :save-bits :delayed    :WIDTH 360    :HEIGHT 400;;  :size '(360 400)    :BORDERS 3    :Panes '((w:color w:color-selector-pane) (w:index cmd-index-pane) (ucl-menu menu-pane))    :constraints '((DEFAULT . ((w:color w:index UCL-MENU)                               ((w:color 0.7))         ((w:index 1 :LINES))                               ((UCL-MENU :EVEN)))))    :active-command-tables '(*color-selector-command-table*)    :all-command-tables    '(*color-selector-command-table*)    :menu-panes            '((UCL-MENU *color-selector-command-menu*))    :blip-alist '((:menu :handle-menu-input)                  (:mouse-button :handle-mouse-input)                  (:direct-command-entry :handle-direct-command-entry)                  (:typeout-execute :handle-typeout-execute))    :label '(:string "Color Map Display" :centered :top :font fonts:hl12bi)    :label-box-p t    )  :settable-instance-variables  (:documentation :combination  "The constraint frame for the color map display."));;; Ensure that we don't try to reuse this frame after we've killed it.  (defmethod (color-map-frame :after :kill) (&rest ignore)  (w:io-buffer-clear (send self :io-buffer))  (when (eq self *color-map-selector*)    (setq *color-map-selector* nil)))(DEFMETHOD (color-map-frame :after :init) (&rest ignore)  (SETQ message-window (MAKE-INSTANCE 'message-window-flavor                                      :blinker-p nil                                      :superior (SEND self :get-pane 'UCL-MENU)                                      ))  (when (and *color-editor-instance*     (send *color-editor-instance* :exposed-p))    (let ((cme-x-offset (send *color-editor-instance* :x-offset)))      (when (<= width cme-x-offset)(send self :set-position       (- cme-x-offset width)      (send *color-editor-instance* :y-offset))))))(defmethod (color-map-frame :after :deexpose) (&rest ignore)  "Makes the color editor exit its command loop if we are deexposed (deselected)"  (send self :force-kbd-input `(:menu ("Exit" :value ,(ucl:get-command '(:method color-map-frame :exit)))      1 ,(send self :get-pane 'ucl-menu))))(defmethod (color-map-frame :before :expose) (&rest ignore)  (w:io-buffer-clear (send self :io-buffer)))(DEFMETHOD (color-map-frame :handle-typeout-execute) ()  (LET ((blip ucl:kbd-input))    (WHEN (AND (LISTP blip)               (EQ (FIRST blip) :typeout-execute)               (EQ (SECOND blip) 'W:DOIT))      (THROW 'Color-Selected (THIRD blip)))))(defmethod (color-map-frame :display-color-map-name) ()   (let* ((map-name (tv:color-map-name (send self :color-map))) (color-index-pane (send self :get-pane 'w:index))  (x-offset-pos (round (send color-index-pane :width) 3)) (top (- (send color-index-pane :inside-height) (+ (send color-index-pane :line-height)    (send color-index-pane :vsp)))))    (SEND color-index-pane :set-cursorpos x-offset-pos top)    (send color-index-pane :clear-eol)    (unless (string-equal map-name "color")      (SEND color-index-pane :string-out (format nil "Map Name:~a" map-name)))))(DEFFLAVOR message-window-flavor ()           (w:temporary-window-mixin            w:minimum-window)  (:default-init-plist    :superior *color-map-selector*    :font-map '(fonts:tr12b)))(DEFUN show-map (&optional (color-map (send (w:window-under-mouse) :color-map))                  (prompt-for-save t))                                  (WHEN (NULL *color-map-selector*)    (SETQ *color-map-selector* (make-instance 'color-map-frame)))  (send *color-map-selector* :set-color-map color-map)  (send *color-map-selector* :set-prompt-for-save prompt-for-save)    ;this flag should be checked upon exit  (send *color-map-selector* :select)  (send *color-map-selector* :display-color-map-name)    ;; Put the mouse inside the box of the color being edited.   (when *color-editor-instance*    (let* ((current-color (send *color-editor-instance* :color-to-edit))   (selector-pane (send *color-map-selector* :get-pane 'w:color))   (color-selector-node-list (send selector-pane :get-node-list))   (current-node (nth (- 255 current-color) color-selector-node-list))   (x-offset (+ (send selector-pane :x-offset) (send *color-map-selector* :x-offset)))   (y-offset (+ (send selector-pane :y-offset) (send *color-map-selector* :y-offset))))      ;; Check the node in case the node list was not in the expected order.       (unless (eql current-color (second current-node))(dolist (node color-selector-node-list)  (when (and (eq :node (first node))     (eql current-color (second node)))    (setq current-node node)    (return))))      (when (eq :node (first current-node))(let ((warp-x (+ x-offset (round (+ (fifth current-node) (third current-node)) 2)))      (warp-y (+ y-offset (round (+ (sixth current-node) (fourth current-node)) 2))))  (w:mouse-warp warp-x warp-y)))))  (multiple-value-prog1 (values (catch 'color-selected  (send *color-map-selector* :command-loop))(send *color-map-selector* :color-map))(send *color-map-selector* :bury)));;; Added optional arg EDIT-P to allow us to suppress the check for system colors if we want to.;;; Added unwind-protect so we can abort out of this cleanly. (DEFMETHOD (color-map-frame :select-a-color) (&optional (prompt "Choose a color with the Mouse:") (edit-p t))  (LET ((prompt-window message-window))    (UNWIND-PROTECT(PROGN  (send prompt-window :set-color-map (tv:color-map))  (SEND prompt-window :expose)  (send prompt-window :select)  (SEND prompt-window :string-out prompt)   (LOOP as (node alternative value) = (SEND self :list-tyi)do (WHEN (AND (EQ node :TYPEOUT-EXECUTE)      (EQ alternative 'W:DOIT)      ;; If we are editing this color, check whether the color is one of the      ;; reserved ones or not and verify that the user really wants to do it.      ;; If we are not editing this color, don't worry about checking it.      (or (not edit-p)  (not (member value (tv:color-map-reserved-slots (tv:color-map)) :test #'=))  (tv:mouse-confirm (format nil "Color # ~d is a system color.~%Edit it anyway?" value))))     (RETURN value))))      (SEND prompt-window :clear-screen)      (SEND prompt-window :deactivate))));;; Use the new optional arg provided for :select-a-color so that we don't bother the user ;;; when the source color is a system color. (DEFCOMMAND (color-map-frame :copy-color) ()  `(:description "Copy a color to another location in the color map." :names "Copy Color" :keys  (#\ctrl-c) :menus *color-selector-command-menu* :documentation "This command allows copying one color from one slot to another." )  (LET* ((from-color (SEND self :select-a-color "Choose one color to copy" NIL))         (to-color (SEND self :select-a-color (STRING-APPEND "copy color "     (FORMAT nil "~,3d" from-color)     " to which color?")))         (color-map (SEND self :color-map)))    (when (and from-color to-color)      (MULTIPLE-VALUE-BIND (r g b)  (tv:read-color-map color-map from-color)(tv:write-color-map color-map to-color r g b)(tv:write-color-lut-buffer to-color r g b )))))(DEFCOMMAND (color-map-frame :exchange-colors) ()  `(:description "Exchange the locations of two colors in the color map." :names "Exchange Colors" :keys (#\ctrl-e) :menus *color-selector-command-menu* :documentation "This command allows two colors to be exchanged." )  (LET* ((color1 (SEND self :select-a-color "Choose one color to exchange"))         (color2 (SEND self :select-a-color (STRING-APPEND "Exchange color "   (FORMAT nil "~,3d" color1)   " with which color?")))         (color-map (SEND self :color-map)))    (when (and color1 color2)      (MULTIPLE-VALUE-BIND (red1 green1 blue1)  (tv:read-color-map color-map color1)(MULTIPLE-VALUE-BIND (red2 green2 blue2)    (tv:read-color-map color-map color2)  (tv:write-color-map color-map color2 red1 green1 blue1)  (tv:write-color-map color-map color1 red2 green2 blue2)  (tv:download-color-lut-buffer color-map 0)  )))))(DEFCOMMAND (color-map-frame :ramp-colors) ()  `(:description "Ramp the color map between two locations." :names "Ramp Colors" :keys (#\ctrl-r) :menus *color-selector-command-menu* :documentation "This command produces a linear ramping of colors." )  (LET* ((color1   (SEND self :select-a-color "Choose the first color to ramp from"))         (color2   (SEND self :select-a-color "Choose the second color to ramp to"))         (color-map (SEND self :color-map))                                  (index-diff (abs (- color2 color1)))  dr dg db r1 g1 b1 color)    (WHEN (> color1 color2)      (psetq color1 color2     color2 color1))    (when (and color1 color2)      (MULTIPLE-VALUE-bind (red1 green1 blue1)  (tv:read-color-map color-map color1)(MULTIPLE-VALUE-bind (red2 green2 blue2)    (tv:read-color-map color-map color2)  ;;check for divide by zero, when start and end points are same, 8/26  (when (zerop index-diff) (setq index-diff 1))  (setq dr (/ (- red2 red1) index-diff))  (setq dg (/ (- green2 green1) index-diff))  (setq db (/ (- blue2 blue1) index-diff))  (setq color color1)  (dotimes (index index-diff)    (setq r1 (round (+ red1 (* index dr)))  g1 (round (+ green1 (* index dg)))  b1 (round (+ blue1 (* index db))))    (tv:write-color-map color-map color r1 g1 b1)    (setq color (1+ color)))))      (tv:download-color-lut-buffer color-map 0))))(defcommand (color-map-frame :exit) ()  `(:description "Exit the Color Map Display." :names "Exit" :keys (#\end) :menus *color-selector-command-menu* :documentation "Exits the color map display.")  (send self :bury)  (send self :quit))(defcommand (color-map-frame :select-color-map) ()                        '(:description "Change to a different color map." :names "Select Color Map" :keys (#\ctrl-m) :menus *color-selector-command-menu* :documentation "Allows a different color map to be displayed.")  (let ((new-map (eval (w:menu-choose tv:*color-maps* :label "Color Maps:"))))    (when new-map      (tv:download-color-lut-buffer new-map)      (SYSTEM:WAIT-REAL-MILLISECONDS 50)      (send self :set-color-map new-map)      (when *color-editor-instance* (send *color-editor-instance* :set-current-color-map new-map)(send *color-editor-instance* :set-original-color-map (tv:copy-color-map new-map))(send *color-editor-instance* :set-wind-under-mouse nil))      (send self :expose)      (send self :select)      (send self :display-color-map-name)          )))(defcommand (color-map-frame :save-color-map) ()    `(:description "Save the color map to a specified pathname." :names "Save Color Map" :Keys (#\ctrl-s) :menus *color-selector-command-menu* :documentation "Saves the color map on the disk.")    (let (symb )      (declare (special pathname))    (setq pathname *color-map-pathname*)    (w:choose-variable-values '((pathname "Pathname" :pathname))    :margin-choices margin-choice-list    :label "Enter a pathname to save color map to:"    :superior tv:default-screen             ;to be able to change the default size    :extra-width 20)    (when doit      (let ((map (send self :color-map)))(setq symb (intern (string-upcase (send (pathname pathname) :name)) 'color))(set symb map)(COMPILER:FASD-COLOR-MAP symb pathname)(setq *color-map-pathname* pathname)(setq doit nil)(send self :display-color-map-name)(when *color-editor-instance*  (send *color-editor-instance* :set-current-color-map map)  (send *color-editor-instance* :set-original-color-map (tv:copy-color-map map))  (send *color-editor-instance* :set-wind-under-mouse nil))))            ))(defun load-a-color-map ()  (let ((return-list nil)(pathname-alist nil)(item nil)(cvv-pathname *color-map-pathname*)(dir-list (cdr (fs:directory-list (send (pathname *color-map-pathname*):new-pathname:name :wild:type :wild:version :newest)))))    (declare (special cvv-pathname))    (dolist (var dir-list return-list)      (let ((pathname (first var))    (file-name nil))(when (member :color-map-symbol (fs:File-Attribute-List pathname))  (setq file-name (send pathname :name))  (pushnew file-name return-list :test #'equal)  (pushnew (list file-name pathname) pathname-alist :test #'equal))))    (setq return-list (pushnew "<Enter Pathname>" return-list :test #'equal))    (setq item (nth-value 1 (w:menu-choose return-list)))    (if (equal item "<Enter Pathname>")(progn  (w:choose-variable-values '((cvv-pathname "Pathname" :pathname))    :margin-choices margin-choice-list    :label "Enter a pathname to load color map from:"    :superior tv:default-screen             ;;;9/16 to be able to change the default size    :extra-width 20)                   (when doit    (cond ((and (probe-file cvv-pathname)                   (member :color-map-symbol (fs:File-Attribute-List cvv-pathname)))   (setq *color-map-pathname* cvv-pathname)   (load *color-map-pathname* :verbose nil))  (t    (send *color-map-selector* :display-an-error "There is no such file to load")   (setq doit nil)   ))))(when item  (setq *color-map-pathname* (cadr (assoc item pathname-alist)))  (load *color-map-pathname* :verbose nil)))    ))(defcommand (color-map-frame :Load-color-map) ()  `(:description "Load a specified color map." :names "Load Color Map" :keys (#\ctrl-l) :documentation "Loads a previously saved color map." :menus *color-selector-command-menu*)  (let ((pathname nil)(symb nil))      (setq pathname (or (load-a-color-map) (and doit *color-map-pathname*)))    (if pathname (setq symb (symbol-value (cadr (member :color-map-symbol(fs:File-Attribute-List pathname))))))    (when symb      (setq doit nil)      (send self :set-color-map symb)      (tv:download-color-lut-buffer symb)      (when *color-editor-instance*(send *color-editor-instance* :set-current-color-map symb)(send *color-editor-instance* :set-original-color-map (tv:copy-color-map symb))(send *color-editor-instance* :set-wind-under-mouse nil))      (send self :select)      (send self :display-color-map-name))))(DEFMETHOD  (color-map-frame :display-an-error) (err-msg)  (LET* ((prompt-window (SEND self :message-window)))    (send prompt-window :set-color-map (send self :color-map))            (SEND prompt-window :expose)    (SEND prompt-window :string-out err-msg)    (send prompt-window :string-out (format nil "~1%"))    (send prompt-window :string-out tv:*remove-typeout-standard-message*)    (tv:read-any)    (send prompt-window :clear-screen)    (send prompt-window :deactivate)))(defcommand (color-map-frame :create-new-map) ()  `(:description "Create a new color map with a defaulted color table." :names "Create New Map" :keys (#\ctrl-N) :menus *color-selector-command-menu* :documentation "Displays the (unmodified) system default color map.")  (let ((map (tv:create-color-map)))    (when *color-editor-instance*      (send *color-editor-instance* :set-current-color-map map)      (send *color-editor-instance* :set-original-color-map (tv:copy-color-map map))      (send *color-editor-instance* :set-wind-under-mouse nil))    (send self :set-color-map map)    (send self :select)    (send self :display-color-map-name)))(defcommand (color-map-frame :get-map-of-window) ()    '(:description "Left click on the desired window to display its color map." :names "Get Map of Window" :keys (#\ctrl-w) :menus  *color-selector-command-menu* :documentation "Displays the color map of the user-selected window." )  (let (wind char offset-x offset-y)    (setq char (send w:mouse-blinker :character))    (multiple-value-setq (offset-x offset-y) (send w:mouse-blinker :offsets))    (send w:mouse-blinker :set-character w:mouse-glyph-hollow-circle-pointer)    (send w:mouse-blinker :set-offsets 8 8)   ;Find the REAL value for these offsets...    (w:with-mouse-grabbed      (setq w:who-line-mouse-grabbed-documentation "Pick a window from the screen")      (process-wait "Pick a Window" #'(lambda () (not (= (w:mouse-buttons) 1))))      (process-wait "Pick a Window" #'(lambda () (= (w:mouse-buttons) 1)))      (setq wind (w:window-under-mouse)))    ;;Restore the original mouse-blinker character    (send w:mouse-blinker :set-character char)    (send w:mouse-blinker :set-offsets offset-x offset-y)    (let ((map (send wind :color-map)))      (send self :set-color-map map)      (when *color-editor-instance*(send *color-editor-instance* :set-current-color-map map)(send *color-editor-instance* :set-original-color-map (tv:copy-color-map map))(send *color-editor-instance* :set-wind-under-mouse nil)))    (send self :select)    (send self :display-color-map-name)))(defun color-map-p (obj) (typep obj 'tv:color-map))(defcommand (color-map-frame :Help) ()  '(:description "Display documentation on how to use Color Map Display." :names ("Help") :keys (#\help))  (display-help *color-map-display-help*))(BUILD-COMMAND-TABLE '*color-selector-command-table* 'color-map-frame  '(:copy-color     :save-color-map     :exchange-colors     :load-color-map     :ramp-colors     :create-new-map     :get-map-of-window     :help     :select-color-map     :exit      ))(BUILD-MENU '*color-selector-command-menu* 'color-map-frame  :item-list-order '(:copy-color      :save-color-map      :exchange-colors      :load-color-map      :ramp-colors      :create-new-map      :get-map-of-window      :help      :select-color-map      :exit       )  :default-item-options '(:font fonts:cptfontb))