;;; -*- Mode:Common-Lisp; Package:W; Base:10; Fonts:(COURIER HL12B HL12BI HL12BI HL12B) -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1988, Texas Instruments Incorporated. All rights reserved. ;1;;* ;1;;* 1The Banded-Color Support...* ;1;;* (DEFVAR 4*banding-scheme-symbol-and-sheets-to-affect* *nil "2Used by USING-BANDING-SCHEME to communicate with sub-macros and sub-functions.*") (COMMENT "3A BANDING-SCHEME has the following structure:*" ((({}*) {}*) (install-clear-color

:sheet sheet :color-map color-map :blinking-color-map blinking-color-map :dual-monitor-mode? dual-monitor-mode? :install-color-map? install-color-map?) { (install-color-for-band

:sheet sheet :color-map color-map :blinking-color-map blinking-color-map :dual-monitor-mode? dual-monitor-mode? :install-color-map? install-color-map?) -OR- (IGNORE

) }* ) ) (DEFSUBST 4extra-color-symbols *(banding-scheme) (CAAR banding-scheme)) (DEFSUBST 4symbols-in-use *(banding-scheme) (CDAR banding-scheme)) (DEFSUBST 4installation-forms *(banding-scheme) (CDR banding-scheme)) (DEFSUBST 4band-color-installation-forms *(banding-scheme) (CDDR banding-scheme)) (DEFSUBST 4clear-color-installation-form *(banding-scheme) (CADR banding-scheme)) (DEFSUBST 4clear-color-symbol *(banding-scheme) (SECOND (clear-color-installation-form banding-scheme))) (DEFSUBST 4clear-red *(banding-scheme) (THIRD (clear-color-installation-form banding-scheme))) (DEFSUBST 4clear-green *(banding-scheme) (FOURTH (clear-color-installation-form banding-scheme))) (DEFSUBST 4clear-blue *(banding-scheme) (FIFTH (clear-color-installation-form banding-scheme))) (DEFSUBST 4clear-blink-red *(banding-scheme) (SIXTH (clear-color-installation-form banding-scheme))) (DEFSUBST 4clear-blink-green *(banding-scheme) (SEVENTH (clear-color-installation-form banding-scheme))) (DEFSUBST 4clear-blink-blue *(banding-scheme) (EIGHTH (clear-color-installation-form banding-scheme))) (DEFSUBST 4installation-function *(band-color-installation-form) (FIRST band-color-installation-form)) (DEFSUBST 4band-symbol *(band-color-installation-form) (SECOND band-color-installation-form)) (DEFSUBST 4band-color-symbol *(band-color-installation-form) (THIRD band-color-installation-form)) (DEFSUBST 4color-map-location *(band-color-installation-form) (THIRD band-color-installation-form)) (DEFSUBST 4band-color-red *(band-color-installation-form) (FOURTH band-color-installation-form)) (DEFSUBST 4band-color-green *(band-color-installation-form) (FIFTH band-color-installation-form)) (DEFSUBST 4band-color-blue *(band-color-installation-form) (SIXTH band-color-installation-form)) (DEFSUBST 4band-color-blink-red *(band-color-installation-form) (SEVENTH band-color-installation-form)) (DEFSUBST 4band-color-blink-green *(band-color-installation-form) (EIGHTH band-color-installation-form)) (DEFSUBST 4band-color-blink-blue *(band-color-installation-form) (NINTH band-color-installation-form)) (DEFUN 4make-band-color-installation-form* (band-symbol color-symbol red-value green-value blue-value &optional blink-red blink-green blink-blue) `(install-color-for-band ,band-symbol ,color-symbol ,red-value ,green-value ,blue-value ,blink-red ,blink-green ,blink-blue :sheet sheet :color-map color-map :blinking-color-map blinking-color-map :dual-monitor-mode? dual-monitor-mode? :install-color-map? install-color-map?)) (DEFUN 4make-empty-band-slot-form* (band-symbol color-map-location) `(IGNORE ,band-symbol ,color-map-location)) (DEFUN 4eval-for-sheets-affected* (form) (LET ((install-color-map? t) sheet color-map blinking-color-map dual-monitor-mode?) (DECLARE (SPECIAL install-color-map? sheet color-map blinking-color-map dual-monitor-mode?)) (DOLIST (sheet-info (CDR *banding-scheme-symbol-and-sheets-to-affect*)) (SETF sheet (FIRST sheet-info) color-map (THIRD sheet-info) blinking-color-map (FOURTH sheet-info) dual-monitor-mode? (FIFTH sheet-info)) (EVAL form)))) (DEFUN 4dual-monitor-color-sheet-p* (&optional (sheet self)) "2Returns T if SHEET is a descendant of a screen which is in dual-monitor-mode. Specifically, returns T if the plane-mask of the ancestor screen is tv:*DEFAULT-DUAL-MONITOR-COLOR-PLANE-MASK*.*" (= (SEND (sheet-get-screen sheet) :plane-mask) tv:*default-dual-monitor-color-plane-mask*)) (DEFUN 4write-sheet-color-map* (index red-value green-value blue-value blink-red blink-green blink-blue &key (sheet self) (color-map (SEND sheet :color-map)) (blinking-color-map (SEND sheet :send-if-handles :blinking-color-map)) (dual-monitor-mode? (dual-monitor-color-sheet-p sheet)) (install-color-map? t)) "2Writes RED-VALUE, GREEN-VALUE, and BLUE-VALUE into COLOR-MAP at location INDEX. When BLINKING-COLOR-MAP is non-NIL, writes BLINK-RED, BLINK-GREEN, and BLINK-BLUE into BLINKING-COLOR-MAP at location INDEX. BLINK-RED, BLINK-GREEN, or BLINK-BLUE may be nil, in which case RED-VALUE, GREEN-VALUE, or BLUE-VALUE, respectively is used. When DUAL-MONITOR-MODE? is non-NIL, also writes the RGB values at location \(LOGXOR INDEX tv:*DEFAULT-DUAL-MONITOR-MONOCHROME-PLANE-MASK*\). When INSTALL-COLOR-MAP? is non-NIL, downloads SHEET's color-map and blinking-color-map to the CSIB if SHEET is exposed and visible. COLOR-MAP, BLINKING-COLOR-MAP, and DUAL-MONITOR-MODE?, when supplied, should be derived in the same manner as the default values. These arguments are provided to allow suppression of excess computation when this function is applied many times to the same SHEET.*" (write-color-map color-map index red-value green-value blue-value) (WHEN dual-monitor-mode? (write-color-map color-map (LOGXOR index tv:*default-dual-monitor-monochrome-plane-mask*) red-value green-value blue-value)) (WHEN blinking-color-map (write-color-map blinking-color-map index (OR blink-red red-value) (OR blink-green green-value) (OR blink-blue blue-value)) (WHEN dual-monitor-mode? (write-color-map blinking-color-map (LOGXOR index tv:*default-dual-monitor-monochrome-plane-mask*) (OR blink-red red-value) (OR blink-green green-value) (OR blink-blue blue-value)))) (WHEN install-color-map? (tv:install-color-map sheet))) (DEFUN 4locations-per-color* (band) "2Returns one less than the number of contiguous locations in a color map which should have the same RGB values so that the color map may be used with BAND. BAND is a plane-mask with contiguous 1 bits. Bits to the right are in inferior bands and bits to the left are in superior bands.*" (LDB (BYTE (HAULONG band) 0) (LOGNOT band))) (DEFUN 4install-color-for-band* (band color red-value green-value blue-value blink-red blink-green blink-blue &key (sheet self) (color-map (SEND sheet :color-map)) (blinking-color-map (SEND sheet :send-if-handles :blinking-color-map)) (dual-monitor-mode? (dual-monitor-color-sheet-p sheet)) (install-color-map? t)) "2Writes RED-VALUE, GREEN-VALUE, and BLUE-VALUE into COLOR-MAP at location COLOR. When BLINKING-COLOR-MAP is non-NIL, writes BLINK-RED, BLINK-GREEN, and BLINK-BLUE into BLINKING-COLOR-MAP at location COLOR. Locations which follow location COLOR also receive the values, as required for plane-mask BAND. If RED-BLINK-VALUE, GREEN-BLINK-VALUE, or BLUE-BLINK-VALUE are specified to be NIL, then BLINKING-COLOR-MAP will be set up such that when an image in a superior band is drawn in COLOR, images it overlays in inferior bands will show through when the superior image blinks off. When INSTALL-COLOR-MAP? is non-NIL and SHEET is exposed and visible, downloads SHEET's color-map and blinking-color-map to the CSIB. COLOR-MAP, BLINKING-COLOR-MAP, and DUAL-MONITOR-MODE?, when supplied, should be derived in the same manner as the default values. These arguments are provided to allow suppression of excess computation when this function is applied many times to the same SHEET.*" (LOOP WITH locations-per-color = (locations-per-color band) FOR color-map-location FROM color TO (+ color locations-per-color) DOING (MULTIPLE-VALUE-BIND (below-red below-green below-blue) (WHEN blinking-color-map (w:read-color-map blinking-color-map ;1; If a pixel-value were COLOR-MAP-LOCATION and zeros were written to the BAND bits of pixel-value,* ;1; this is the pixel-value which would result...* (LOGAND locations-per-color color-map-location))) (write-sheet-color-map color-map-location red-value green-value blue-value (OR blink-red below-red) (OR blink-green below-green) (OR blink-blue below-blue) :sheet sheet :color-map color-map :blinking-color-map blinking-color-map :dual-monitor-mode? dual-monitor-mode? :install-color-map? nil))) (WHEN install-color-map? (tv:install-color-map sheet))) (DEFUN 4install-clear-color* (clear-color red-value green-value blue-value blink-red blink-green blink-blue &key (sheet self) (color-map (SEND sheet :color-map)) (blinking-color-map (SEND sheet :send-if-handles :blinking-color-map)) (dual-monitor-mode? (dual-monitor-color-sheet-p sheet)) (install-color-map? t)) "2Writes RED-VALUE, GREEN-VALUE, and BLUE-VALUE into COLOR-MAP at location CLEAR-COLOR. CLEAR-COLOR should be zero. When BLINKING-COLOR-MAP is non-NIL, writes BLINK-RED, BLINK-GREEN, and BLINK-BLUE into BLINKING-COLOR-MAP at location CLEAR-COLOR. BLINK-RED, BLINK-GREEN, or BLINK-BLUE may be nil, in which case RED-VALUE, GREEN-VALUE, or BLUE-VALUE, respectively is used. When INSTALL-COLOR-MAP? is non-NIL and SHEET is exposed and visible, downloads SHEET's color-map and blinking-color-map to the CSIB. COLOR-MAP, BLINKING-COLOR-MAP, and DUAL-MONITOR-MODE?, when supplied, should be derived in the same manner as the default values. These arguments are provided to allow suppression of excess computation in contexts where these values have already been derived for SHEET.*" (write-sheet-color-map clear-color red-value green-value blue-value blink-red blink-green blink-blue :sheet sheet :color-map color-map :blinking-color-map blinking-color-map :dual-monitor-mode? dual-monitor-mode? :install-color-map? install-color-map?)) (DEFMACRO 4make-banding-scheme* (banding-scheme-symbol (&optional (clear-color-symbol '*transparent-white*) (clear-red 255) (clear-green 255) (clear-blue 255) (clear-blink-red clear-red) (clear-blink-green clear-green) (clear-blink-blue clear-blue)) (&optional (dual-monitor-mode? nil) (system-colors-band-symbol '*system-colors*) &rest extra-color-symbols) &body &list-of (band-symbol (&body &list-of (color-symbol red-value green-value blue-value &optional ;1; HACK ALERT -- defaults rely on local symbol used by DEFMACRO...* (red-blink-value (SECOND sys::x)) ;1default to red-value for this color-symbol* (green-blink-value (THIRD sys::x)) ;1default to green-value for this color-symbol* (blue-blink-value (FOURTH sys::x)))) ;1default to blue-value for this color-symbol* ;1; HACK ALERT -- default relies on local symbol used by DEFMACRO...* &optional (number-of-colors (LENGTH (SECOND sys::x))))) "2Creates a banding-scheme for use with USING-BANDING-SCHEME. Bands specified earlier in the list of arguments are \"superior\" to bands specified later in the list. Images drawn in superior bands will overlay images drawn in inferior bands. The clear-color may be used in any band. The CLEAR-COLOR-SYMBOL has a color-map-location value of zero. In areas drawn with clear-color, the images in the inferior bands \"show through\". Each COLOR-SYMBOL is declared globally special and given a color-map-location as a value. Each BAND-SYMBOL is declared globally special and given a plane-mask as a value. BANDING-SCHEME-SYMBOL is declared globally special and given a value such that \(INSTALL-BANDED-COLORS \) will install the appropriate color-map in . The number of colors which a band may have is \(1- \(EXPT 2 \)\). Each band is made big enough to hold at least NUMBER-OF-COLORS. NUMBER-OF-COLORS for each band defaults to the number of COLOR-SYMBOLs given for that band. Any COLOR-SYMBOL for a band which exceeds the NUMBER-OF-COLORS for the band is added to EXTRA-COLOR-SYMBOLS. EXTRA-COLOR-SYMBOLS are not given a color-map-location value, but may be used later in calls to REASSIGN-COLOR-WITHIN-BAND, ADD-A-COLOR-TO-A-BAND, and CHANGE-CLEAR-COLOR. When DUAL-MONITOR-MODE? in non-NIL, the highest plane is reserved for use by the monochrome monitor. When SYSTEM-COLORS-BAND-SYMBOL is non-NIL, the lowest planes are reserved for the system colors. RED-BLINK-VALUE, GREEN-BLINK-VALUE, and BLUE-BLINK-VALUE default to RED-VALUE, GREEN-VALUE, and BLUE-VALUE for that COLOR-SYMBOL, respectively. This results in no visible blink. If RED-BLINK-VALUE, GREEN-BLINK-VALUE, or BLUE-BLINK-VALUE are specified to be NIL, then when the blinking-color-map is set up for a sheet, the corresponding blinking colors will be set up such that when an image in a superior band is drawn in that color, images it overlays in inferior bands will show through when the superior image blinks off.*" ;1; Must use WORKING-STORAGE-AREA because value of BANDING-SCHEME-SYMBOL is retained after macro expansion...* (LET* ((default-cons-area working-storage-area) (defparameter-forms (LIST `(DEFPARAMETER ,clear-color-symbol 0))) band-color-installation-forms (symbols-in-use (LIST clear-color-symbol banding-scheme-symbol))) (WHEN (/= (LENGTH extra-color-symbols) (LENGTH (REMOVE-DUPLICATES extra-color-symbols :test #'EQ))) (FERROR nil "3Duplicates not allowed in EXTRA-COLOR-SYMBOLS*")) (WHEN (EQ clear-color-symbol banding-scheme-symbol) (FERROR nil "3~A may not be used as a symbol for both the clear color and the banding scheme.*" clear-color-symbol)) (WHEN (MEMBER banding-scheme-symbol extra-color-symbols :test #'EQ) (FERROR nil "3~A may not be used as a symbol for both the banding scheme and an extra color.*" banding-scheme-symbol)) (WHEN (MEMBER clear-color-symbol extra-color-symbols :test #'EQ) (FERROR nil "3~A may not be used as a symbol for both the clear color and an extra color.*" clear-color-symbol)) (WHEN system-colors-band-symbol (SETF band-symbol (APPEND band-symbol (LIST system-colors-band-symbol)) color-symbol (APPEND color-symbol (LIST nil)) red-value (APPEND red-value (LIST nil)) green-value (APPEND green-value (LIST nil)) blue-value (APPEND blue-value (LIST nil)) red-blink-value (APPEND red-blink-value (LIST nil)) green-blink-value (APPEND green-blink-value (LIST nil)) blue-blink-value (APPEND blue-blink-value (LIST nil)) number-of-colors (APPEND number-of-colors (LIST (1- (LENGTH tv:*default-initial-colors*)))))) (LOOP FOR band-symbol IN band-symbol AND FOR color-symbol-list IN color-symbol AND FOR red-value-list IN red-value AND FOR green-value-list IN green-value AND FOR blue-value-list IN blue-value AND FOR red-blink-value-list IN red-blink-value AND FOR green-blink-value-list IN green-blink-value AND FOR blue-blink-value-list IN blue-blink-value AND FOR number-of-colors IN number-of-colors FOR number-of-planes = (HAULONG number-of-colors) FOR last-plane-used FIRST (- (IF dual-monitor-mode? 7. 8.) number-of-planes) THEN (- last-plane-used number-of-planes) FOR lowest-color-map-location = (ASH 1 last-plane-used) AND FOR plane-mask = (ASH (1- (ASH 1 number-of-planes)) last-plane-used) DOING (WHEN (MINUSP last-plane-used) (FERROR nil "3More colors and/or bands specified for ~A than will fit in available color planes.*" banding-scheme-symbol)) (IF (OR (MEMBER band-symbol symbols-in-use :test #'EQ) (MEMBER band-symbol extra-color-symbols :test #'EQ)) (FERROR nil "3~A, used as a band symbol, is also used as a symbol elsewhere in ~A*" band-symbol banding-scheme-symbol) ;1; ELSE...* (PUSH band-symbol symbols-in-use)) (PUSH `(DEFPARAMETER ,band-symbol ,plane-mask) defparameter-forms) (LOOP WITH color-symbol FOR color-map-location FROM lowest-color-map-location BY lowest-color-map-location TO plane-mask AND FOR color-number FROM 0 DOING (IF (AND (< color-number number-of-colors) color-symbol-list) (IF (OR (MEMBER (POP color-symbol-list color-symbol) symbols-in-use :test #'EQ) (MEMBER color-symbol extra-color-symbols :test #'EQ)) (FERROR nil "3~A, used as a color symbol in band ~A, is also used as a symbol elsewhere in ~A*" color-symbol band-symbol banding-scheme-symbol) ;1; ELSE...* (PUSH color-symbol symbols-in-use) (PUSH `(DEFPARAMETER ,color-symbol ,color-map-location) defparameter-forms) (PUSH (make-band-color-installation-form band-symbol color-symbol (POP red-value-list) (POP green-value-list) (POP blue-value-list) (POP red-blink-value-list) (POP green-blink-value-list) (POP blue-blink-value-list)) band-color-installation-forms)) ;1; ELSE, ran out of colors, so leave a space to be filled in later...* (PUSH (make-empty-band-slot-form band-symbol color-map-location) band-color-installation-forms)) FINALLY (LOOP FOR color-symbol IN color-symbol-list DOING (IF (OR (MEMBER color-symbol symbols-in-use :test #'EQ) (MEMBER color-symbol extra-color-symbols :test #'EQ)) (FERROR nil "3~A, used as a color symbol in band ~A, is also used as a symbol elsewhere in ~A*" color-symbol band-symbol banding-scheme-symbol) ;1; ELSE...* (PUSH color-symbol extra-color-symbols))))) ;1; Value of BANDING-SCHEME-SYMBOL must be bound at compile time to be used by USING-BANDING-SCHEME macro expansion...* (SET banding-scheme-symbol (LIST* (CONS extra-color-symbols symbols-in-use) `(install-clear-color ,clear-color-symbol ,clear-red ,clear-green ,clear-blue ,clear-blink-red ,clear-blink-green ,clear-blink-blue :sheet sheet :color-map color-map :blinking-color-map blinking-color-map :dual-monitor-mode? dual-monitor-mode? :install-color-map? install-color-map?) band-color-installation-forms)) ;1; Macro expands into DEFPARAMETER forms...* `(PROGN ,@(LOOP FOR extra-color-symbol IN extra-color-symbols COLLECTING `(DEFPARAMETER ,extra-color-symbol nil)) ,@defparameter-forms (DEFPARAMETER ,banding-scheme-symbol ',(SYMBOL-VALUE banding-scheme-symbol))))) (DEFUN 4install-banded-colors* (banding-scheme &optional (sheet self) (install-color-map t)) "2Sets up SHEET's color-map and blinking-color-map for use with bands and colors defined for BANDING-SCHEME. No copy of the color-maps is made or restored. See USING-BANDING-SCHEME.*" (DECLARE (SPECIAL sheet)) (LET* ((color-map (SEND sheet :color-map)) (blinking-color-map (WHEN (SEND sheet :operation-handled-p :set-blinking-color-map) (OR (SEND sheet :blinking-color-map) (SEND sheet :set-blinking-color-map (w:copy-color-map color-map) t)))) (dual-monitor-mode? (dual-monitor-color-sheet-p sheet)) (install-color-map? nil)) (DECLARE (SPECIAL color-map blinking-color-map dual-monitor-mode? install-color-map?)) (MAPC #'EVAL (installation-forms banding-scheme)) (WHEN install-color-map (tv:install-color-map sheet)))) (DEFMACRO 4using-banding-scheme* ((banding-scheme-symbol &rest &list-of (sheet-to-affect &optional (inherit? t))) &body body) "2Executes BODY forms with the color-map defined for BANDING-SCHEME-SYMBOL in effect for each SHEET-TO-AFFECT. Restores the original color-maps on normal exit or throw from this form. The compiler must see the call to MAKE-BANDING-SCHEME which defined BANDING-SCHEME-SYMBOL before it sees calls to this macro. The value of INHERIT? for each SHEET-TO-AFFECT determines whether or not inferior sheets which do not have their own color-maps get pointers to the new color-map. It also determines whether or not inferior sheets which do not have their own plane-masks get pointers to the new plane-masks when USING-BANDS is used within the dynamic scope of USING-BANDING-SCHEME. *BANDING-SCHEME-SYMBOL-AND-SHEETS-TO-AFFECT* is bound within the dynamic scope of USING-BANDING-SCHEME. Modify this variable at your own risk. USING-BANDS, CHANGE-CLEAR-COLOR, REASSIGN-COLOR-WITHIN-BAND, REMOVE-A-COLOR-FROM-ITS-BAND, and ADD-A-COLOR-TO-A-BAND reference *BANDING-SCHEME-SYMBOL-AND-SHEETS-TO-AFFECT* as a special variable.*" (LET ((old-color-maps (GENSYM)) (old-blinking-color-maps (GENSYM)) (sheets-to-affect (GENSYM)) (inherit-list (GENSYM)) ;1; BANDING-SCHEME-SYMBOL must be bound at compile time for this to work...* (banding-scheme (SYMBOL-VALUE banding-scheme-symbol))) `(LET* ((,sheets-to-affect (LIST ,@sheet-to-affect)) (,inherit-list (LIST ,@inherit?)) (,old-color-maps (LOOP FOR sheet IN ,sheets-to-affect COLLECTING (SEND sheet :color-map))) (,old-blinking-color-maps (LOOP FOR sheet IN ,sheets-to-affect COLLECTING (SEND sheet :send-if-handles :blinking-color-map))) ;1; Put the symbols defined by the banding scheme in the LET so that changes to the same symbols in different* ;1; processes will be independent. Initial local values will be the same as the global values...* ,@(LOOP FOR symbol IN (APPEND (extra-color-symbols banding-scheme) (symbols-in-use banding-scheme)) COLLECTING `(,symbol ,symbol)) ;1; establish place to record information needed for sub-macros and sub-functions...* ;1; Use LIST instead of QUOTE here to force a new cons cell each time. The NREVERSE below mungs this cons cell...* (*banding-scheme-symbol-and-sheets-to-affect* (LIST ',banding-scheme-symbol))) ;1; Make a process-local copy of the banding scheme to ensure process independent changes...* (SETF ,banding-scheme-symbol (COPY-TREE ,banding-scheme-symbol)) (UNWIND-PROTECT (PROGN (LOOP WITH install-color-map? = nil FOR sheet IN ,sheets-to-affect AND FOR old-color-map IN ,old-color-maps AND FOR old-blinking-color-map IN ,old-blinking-color-maps AND FOR inherit? IN ,inherit-list FOR dual-monitor-mode? = (dual-monitor-color-sheet-p sheet) AND FOR color-map = (IF old-color-map (w:copy-color-map old-color-map) ;1; ELSE...* (w:create-color-map)) FOR blinking-color-map = (WHEN (SEND sheet :operation-handled-p :set-blinking-color-map) (IF old-blinking-color-map (w:copy-color-map old-blinking-color-map) ;1; ELSE...* (w:copy-color-map color-map))) DOING (PUSH (LIST sheet inherit? color-map blinking-color-map dual-monitor-mode?) *banding-scheme-symbol-and-sheets-to-affect*) (SEND sheet :set-color-map color-map inherit?) (WHEN blinking-color-map (SEND sheet :set-blinking-color-map blinking-color-map inherit?)) ,@(installation-forms banding-scheme) (tv:install-color-map sheet)) (SETF *banding-scheme-symbol-and-sheets-to-affect* (NREVERSE *banding-scheme-symbol-and-sheets-to-affect*)) ,@body) ;1; but always restore the original color maps...* (LOOP FOR sheet IN ,sheets-to-affect AND FOR old-color-map IN ,old-color-maps AND FOR old-blinking-color-map IN ,old-blinking-color-maps AND FOR inherit? IN ,inherit-list DOING (SEND sheet :set-color-map old-color-map inherit?) (SEND sheet :send-if-handles :set-blinking-color-map old-blinking-color-map inherit?) (tv:install-color-map sheet)))))) (DEFUN 4reassign-color-within-band* ("e old-color-symbol new-color-symbol &eval red-value green-value blue-value &optional (blink-red red-value) (blink-green green-value) (blink-blue blue-value)) "2Must be used within the dynamic scope of USING-BANDING-SCHEME. Replaces OLD-COLOR-SYMBOL with NEW-COLOR-SYMBOL in the banding-scheme currently in effect. If NEW-COLOR-SYMBOL is not EQ to OLD-COLOR-SYMBOL, then NEW-COLOR-SYMBOL must be a member of the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. OLD-COLOR-SYMBOL is substituted for NEW-COLOR-SYMBOL on the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. NEW-COLOR-SYMBOL is assigned the value of OLD-COLOR-SYMBOL. RED-VALUE, GREEN-VALUE, and BLUE-VALUE are written to the color-maps of the affected sheets at the color-map-location which is the value of OLD-COLOR-SYMBOL and at following locations as required for the band in which OLD-COLOR-SYMBOL is defined. BLINK-RED, BLINK-GREEN, and BLINK-BLUE are written to the blinking-color-maps of the affected sheets at the color-map-location which is the value of OLD-COLOR-SYMBOL and at following locations as required for the band in which OLD-COLOR-SYMBOL is defined. If BLINK-RED, BLINK-GREEN, or BLINK-BLUE are specified as NIL, then the blinking-color-map of the affected sheets will be set up such that when an image in a superior band is drawn in the new color, images it overlays in inferior bands will show through when the superior image blinks off. NOTE: Colors in superior bands which were set up to blink to colors in inferior bands \(3by specifying a blink-value of NIL*\3)** 2will still blink to the old color, not the new color.*" (IF *banding-scheme-symbol-and-sheets-to-affect* (LET* ((banding-scheme-symbol (CAR *banding-scheme-symbol-and-sheets-to-affect*)) (banding-scheme (SYMBOL-VALUE banding-scheme-symbol))) (IF (OR (EQ new-color-symbol old-color-symbol) (MEMBER new-color-symbol (extra-color-symbols banding-scheme) :test #'EQ)) (LET ((band-color-installation-form (FIND old-color-symbol (band-color-installation-forms banding-scheme) :key #'band-color-symbol :test #'EQ))) (IF band-color-installation-form (PROGN (WHEN (NEQ new-color-symbol old-color-symbol) (SETF (symbols-in-use banding-scheme) (NSUBSTITUTE new-color-symbol old-color-symbol (symbols-in-use banding-scheme) :test #'EQ) (extra-color-symbols banding-scheme) (NSUBSTITUTE old-color-symbol new-color-symbol (extra-color-symbols banding-scheme) :test #'EQ) (band-color-symbol band-color-installation-form) new-color-symbol) (SET new-color-symbol (SYMBOL-VALUE old-color-symbol))) (SETF (band-color-red band-color-installation-form) red-value (band-color-green band-color-installation-form) green-value (band-color-blue band-color-installation-form) blue-value (band-color-blink-red band-color-installation-form) blink-red (band-color-blink-green band-color-installation-form) blink-green (band-color-blink-blue band-color-installation-form) blink-blue) (eval-for-sheets-affected band-color-installation-form)) ;1; ELSE...* (FERROR nil "3~A is not a color in a band in ~A*" old-color-symbol banding-scheme-symbol))) ;1; ELSE...* (FERROR nil "3~A is not an EXTRA-COLOR-SYMBOL in ~A.*" new-color-symbol banding-scheme-symbol))) ;1; ELSE...* (FERROR nil "3REASSIGN-COLOR-WITHIN-BAND called outside the dynamic scope of USING-BANDING-SCHEME*"))) (DEFUN 4add-a-color-to-a-band* ("e band-symbol-or-color-symbol new-color-symbol &eval red-value green-value blue-value &optional (blink-red red-value) (blink-green green-value) (blink-blue blue-value)) "2Must be used within the dynamic scope of USING-BANDING-SCHEME. Adds NEW-COLOR-SYMBOL to the banding-scheme currently in effect. NEW-COLOR-SYMBOL must be a member of the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. NEW-COLOR-SYMBOL is removed from the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. If BAND-SYMBOL-OR-COLOR-SYMBOL is a band-symbol, the first available color-map-location for that band is used. Otherwise, the value of BAND-SYMBOL-OR-COLOR-SYMBOL is used if it matches an available color-map-location. NEW-COLOR-SYMBOL is assigned the color-map-location. RED-VALUE, GREEN-VALUE, and BLUE-VALUE are written to the color-maps of the affected sheets at the color-map-location and at following locations as required for the band. BLINK-RED, BLINK-GREEN, and BLINK-BLUE are written to the blinking-color-maps of the affected sheets at the color-map-location and at following locations as required for the band. If BLINK-RED, BLINK-GREEN, or BLINK-BLUE are specified as NIL, then the blinking-color-map of the affected sheets will be set up such that when an image in a superior band is drawn in the new color, images it overlays in inferior bands will show through when the superior image blinks off. NOTE: Colors in superior bands which were set up to blink to colors in inferior bands \(3by specifying a blink-value of NIL*\3)** 2will still blink to the old color, not the new color.*" (IF *banding-scheme-symbol-and-sheets-to-affect* (LET* ((banding-scheme-symbol (CAR *banding-scheme-symbol-and-sheets-to-affect*)) (banding-scheme (SYMBOL-VALUE banding-scheme-symbol))) (IF (MEMBER new-color-symbol (extra-color-symbols banding-scheme) :test #'EQ) (LET* ((band-color-installation-forms (band-color-installation-forms banding-scheme)) (band-color-installation-form (LOOP WITH color-map-location = (SYMBOL-VALUE band-symbol-or-color-symbol) FOR form IN band-color-installation-forms WHEN (AND (EQ (installation-function form) 'IGNORE) (OR (EQ (band-symbol form) band-symbol-or-color-symbol) (EQL color-map-location (color-map-location form)))) RETURN form))) (IF band-color-installation-form (LET ((new-band-color-installation-form (make-band-color-installation-form (band-symbol band-color-installation-form) new-color-symbol red-value green-value blue-value blink-red blink-green blink-blue))) (PUSH new-color-symbol (symbols-in-use banding-scheme)) (SET new-color-symbol (color-map-location band-color-installation-form)) (SETF (band-color-installation-forms banding-scheme) (NSUBSTITUTE new-band-color-installation-form band-color-installation-form band-color-installation-forms :test #'EQ) (extra-color-symbols banding-scheme) (DELETE new-color-symbol (extra-color-symbols banding-scheme) :test #'EQ)) (eval-for-sheets-affected new-band-color-installation-form)) ;1; ELSE...* (IF (MEMBER band-symbol-or-color-symbol (band-color-installation-forms banding-scheme) :test #'EQ :key #'band-symbol) (FERROR nil "3No room available for another color in ~A*" band-symbol-or-color-symbol) ;1; ELSE...* (FERROR nil "3Color map location ~A is not available in ~A*" (SYMBOL-VALUE band-symbol-or-color-symbol) banding-scheme-symbol)))) ;1; ELSE...* (FERROR nil "3~A is not an EXTRA-COLOR-SYMBOL in ~A.*" new-color-symbol banding-scheme-symbol))) ;1; ELSE...* (FERROR nil "3ADD-A-COLOR-TO-A-BAND called outside the dynamic scope of USING-BANDING-SCHEME*"))) (DEFUN 4remove-a-color-from-its-band* ("e color-symbol) "2Must be used within the dynamic scope of USING-BANDING-SCHEME. Removes COLOR-SYMBOL from its band in the banding-scheme currently in effect. COLOR-SYMBOL is pushed onto the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. This allows COLOR-SYMBOL to be assigned some other color-map-location later. This has no immediate effect on any color-map or window.*" (IF *banding-scheme-symbol-and-sheets-to-affect* (LET* ((banding-scheme-symbol (CAR *banding-scheme-symbol-and-sheets-to-affect*)) (banding-scheme (SYMBOL-VALUE banding-scheme-symbol)) (band-color-installation-forms (band-color-installation-forms banding-scheme)) (band-color-installation-form (FIND color-symbol band-color-installation-forms :key #'band-color-symbol :test #'EQ))) (IF band-color-installation-form (SETF (band-color-installation-forms banding-scheme) (NSUBSTITUTE (make-empty-band-slot-form (band-symbol band-color-installation-form) (SYMBOL-VALUE color-symbol)) band-color-installation-form band-color-installation-forms :test #'EQ) (symbols-in-use banding-scheme) (DELETE color-symbol (symbols-in-use banding-scheme) :test #'EQ) (extra-color-symbols banding-scheme) (CONS color-symbol (extra-color-symbols banding-scheme))) ;1; ELSE...* (FERROR nil "3~A is not currently a color in a band in ~A*" color-symbol banding-scheme-symbol))) ;1; ELSE...* (FERROR nil "3REMOVE-A-COLOR-FROM-ITS-BAND called outside the dynamic scope of USING-BANDING-SCHEME*"))) (DEFUN 4change-clear-color* ("e new-clear-color-symbol &eval red-value green-value blue-value &optional (blink-red red-value) (blink-green green-value) (blink-blue blue-value)) "2Must be used within the dynamic scope of USING-BANDING-SCHEME. Replaces previous clear-color-symbol with NEW-CLEAR-COLOR-SYMBOL in the banding-scheme currently in effect. If NEW-CLEAR-COLOR-SYMBOL is not the previous clear-color-symbol in the banding-scheme currently in effect, then NEW-CLEAR-COLOR-SYMBOL must be a member of the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. The previous clear-color-symbol is substituted for NEW-CLEAR-COLOR-SYMBOL on the EXTRA-COLOR-SYMBOLS list of the banding-scheme currently in effect. NEW-CLEAR-COLOR-SYMBOL is assigned the value of the previous clear-color-symbol (3zero)*. RED-VALUE, GREEN-VALUE, and BLUE-VALUE are written to the color-maps of the affected sheets at color-map-location zero. BLINK-RED, BLINK-GREEN, and BLINK-BLUE are written to the blinking-color-maps of the affected sheets at color-map-location zero. NOTE: Colors in superior bands which were set up to blink to colors in inferior bands \(3by specifying a blink-value of NIL*\3)** 2will still blink to the old color, not the new color.*" (IF *banding-scheme-symbol-and-sheets-to-affect* (LET* ((banding-scheme-symbol (CAR *banding-scheme-symbol-and-sheets-to-affect*)) (banding-scheme (SYMBOL-VALUE banding-scheme-symbol)) (clear-color-symbol (clear-color-symbol banding-scheme))) (UNLESS (EQ clear-color-symbol new-clear-color-symbol) (IF (MEMBER new-clear-color-symbol (extra-color-symbols banding-scheme) :test #'EQ) (SETF (symbols-in-use banding-scheme) (NSUBSTITUTE new-clear-color-symbol clear-color-symbol (symbols-in-use banding-scheme) :test #'EQ) (extra-color-symbols banding-scheme) (NSUBSTITUTE clear-color-symbol new-clear-color-symbol (extra-color-symbols banding-scheme) :test #'EQ) (clear-color-symbol banding-scheme) new-clear-color-symbol) ;1; ELSE...* (FERROR nil "3~A is not an EXTRA-COLOR-SYMBOL in ~A.*" new-clear-color-symbol banding-scheme-symbol))) (SETF (clear-red banding-scheme) red-value (clear-green banding-scheme) green-value (clear-blue banding-scheme) blue-value (clear-blink-red banding-scheme) blink-red (clear-blink-green banding-scheme) blink-green (clear-blink-blue banding-scheme) blink-blue) (SET new-clear-color-symbol (SYMBOL-VALUE clear-color-symbol)) (eval-for-sheets-affected (clear-color-installation-form banding-scheme))) ;1; ELSE...* (FERROR nil "3CHANGE-CLEAR-COLOR called outside the dynamic scope of USING-BANDING-SCHEME*"))) (DEFUN 4set-sheet-plane-mask* (new-plane-mask &optional (sheet self) (inherit? t)) "2Sets SHEET's plane-mask to NEW-PLANE-MASK. When INHERIT? is non-NIL, sets SHEET's inferiors' plane-masks to NEW-PLANE-MASK, if they do not already have a plane-mask different from SHEET's.*" (WHEN inherit? (LOOP WITH plane-mask = (SEND sheet :plane-mask) FOR inferior IN (SEND sheet :inferiors) FOR inferior-plane-mask = (SEND inferior :plane-mask) WHEN (EQ inferior-plane-mask plane-mask) DOING (set-sheet-plane-mask new-plane-mask inferior t))) (SEND sheet :set-plane-mask new-plane-mask)) (DEFMACRO 4using-bands* ((&rest bands) (&rest &list-of (sheet-to-affect &optional (inherit? t))) &body body) "2Executes BODY forms so that drawing to the affected sheets only draws in BANDS. Restores the plane-masks of the affected sheets on exit or throw from this form. When no SHEET-TO-AFFECT is specified, and this form is used within the dynamic scope of USING-BANDING-SCHEME, the sheets specified by that form are used.*" (LET ((old-plane-masks (GENSYM)) (sheets-to-affect (GENSYM))) `(IF ,(IF sheet-to-affect t '*banding-scheme-symbol-and-sheets-to-affect*) (LET* ((,sheets-to-affect ,(IF sheet-to-affect ;1; ELSE...* (CONS 'LIST (LOOP FOR sheet IN sheet-to-affect AND FOR inherit? IN inherit? COLLECTING `(LIST ,sheet ,inherit?))) '(CDR *banding-scheme-symbol-and-sheets-to-affect*))) (,old-plane-masks (LOOP FOR (sheet) IN ,sheets-to-affect COLLECTING (SEND sheet :plane-mask)))) (UNWIND-PROTECT (PROGN (LOOP WITH plane-mask = ,(IF (CDR bands) `(LOGIOR ,@bands) ;1; ELSE...* (CAR bands)) FOR (sheet inherit?) IN ,sheets-to-affect DOING (set-sheet-plane-mask plane-mask sheet inherit?)) ,@body) ;1; but always restore the original plane-masks...* (LOOP FOR (sheet inherit?) IN ,sheets-to-affect AND FOR old-plane-mask IN ,old-plane-masks DOING (set-sheet-plane-mask old-plane-mask sheet inherit?)))) ;1; ELSE...* ,(UNLESS sheet-to-affect '(FERROR nil "3USING-BANDS called outside the dynamic scope of USING-BANDING-SCHEME~%~ and no SHEET-TO-AFFECT was specified.*"))))) (DEFMACRO 4with-background-color* ((color &optional (sheet self)) &body body) (LET ((original-background-color (GENSYM))) (ONCE-ONLY (color sheet) `(LET ((,original-background-color (SEND ,sheet :background-color))) (UNWIND-PROTECT (PROGN (SEND ,sheet :set-background-color ,color) ,@body) ;1; but always restore background color...* (SEND ,sheet :set-background-color ,original-background-color)))))) (DEFUN 4paint-window* (color &optional (sheet self)) (with-background-color (color sheet) (SEND sheet :clear-screen)))