;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Changes to window LABELS to correct problems with ;;; border widths and label drawing with fonts and ;;; with border-margin-widths. ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 10/25/89 09:58:09 by marky, ;;; while running on LIBRA from band LODA ;;; With SYSTEM 6.22, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1, ;;; BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.6, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.4, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.17, DATALINK 6.0, CHAOSNET 6.1, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.7, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.3, MAIL-READER 6.5, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.3, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.26, CLEH 6.5, IP 3.54, ;;; Experimental CLX 6.6, CLUE 6.26, X11M 6.15, Experimental BUG 11.15, MMON 6.2, ;;; microcode 429, Band Name: REL6-mmon-10/23/89 ;;; SPR's 10146, 5713 - window border :top and :right mixed up. Patched tv:PARSE-BORDERS-SPEC ;;; ;;; SPR's 10144, 10136 - font can-t be determined when w:default-screen is nil in labels ;;; Patched LABEL-HEIGHT & (LABEL-MIXIN :LABEL-SIZE) & (LABEL-MIXIN :DRAW-LABEL) ;;; ;;; (no spr) - bug discovered in regresson testing : A color w:window on explorer with a bottom label ;;; and a label color will try to "scoot" or fill into border-margin-width-area - to "look better". This ;;; was broken for labels on the bottom and the scoot was upward instead of downward. This has been ;;; fixed. In addition, the :really-boxed? method of the tv:box-label-mixin and tv:borders-mixin ;;; flavors default to NIL and T respectively ( this may seem backward to you, as it does me ) but ;;; NOW you can redefine either of these methods for your window and eliminate the filling altogether ;;; if your method returns :dont-fill. This will result in the behavior described/pictured in the ;;; window manual in para 3.1. This is best explained with an example : ;;; ;;; (no spr) - fix bug in (screen :set-reverse-video) method - never called by system. (comment "Test code for labels" (defflavor w:box-w () (w:box-label-mixin w:window)) (defflavor w:window2 () (w:window)) ;; Pick one of methods below : (defmethod (w:window2 :really-boxed?) () t) ;; default behaviour - fills label inot border-margin-width-area (defmethod (w:window2 :really-boxed?) () :dont-fill) ;; optional behavior - label stays out of border-margin-width-area (defun tw () (declare (special tw)) (setq tw (make-instance 'w:window2 ;; 'w:window ;; 'tv:box-w :name "message-window-name" :foreground-color w:black :background-color w:white :border-color w:blue :deexposed-typeout-action :expose :left 200;x-margin :top 200;y-margin :width 400;test-width :height 300;test-height :borders 10 :border-margin-width 20 ;; :label-box-color w:green ;; <- only works for w:box-label-mixin :label `(:string "Message window, yellow on magenta 2134567890" ;; :top ;; defaults to :bottom :color ,w:yellow :background ,w:magenta) :more-p nil))) (tw) (progn (send tw :expose) (send tw :draw-arc 200 200 30 200 360 30 )) ;; note the label is drawn into since it is :border-margin-width pixels ;; too TALL. It should be 13 pixels tall for :line-height of cptfont and ;; 2-pixel vsp. ) ;; end comment #!C ; From file BASWIN.LISP#> WINDOW; Hotel: #10R TV#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; BASWIN.#" ;;; SPR's 10146, 5713 - window border :top and :right mixed up. Patched tv:PARSE-BORDERS-SPEC (DEFUN PARSE-BORDERS-SPEC (SPEC LM TM RM BM FUNCTION &OPTIONAL DEFAULT-SIZE new-color) (DECLARE (:SELF-FLAVOR BORDERS-MIXIN)) (COND ;;NIL means no borders at all (SPEC ;;A symbol or an number means that type for each of the four, else make a copy ;;a plist of (:LEFT FOO :RIGHT BAR) works too (IF new-color (SETQ border-color new-color) ) (SETQ SPEC (COND ((ATOM SPEC) (SETQ SPEC (LIST SPEC SPEC SPEC SPEC))) ((MEMBER (CAR SPEC) '(:LEFT :RIGHT :TOP :BOTTOM :COLOR) :TEST #'EQ) (DO ((NSPEC (IF (ATOM BORDERS) (LIST BORDERS BORDERS BORDERS BORDERS) ;;ELSE ;; Create an empty borders specification. (LIST NIL NIL NIL NIL))) (SPEC SPEC (CDDR SPEC))) ((NULL SPEC) NSPEC) (SETF ;; may 10/25/89 Swapped :top :right below to match (NTH (POSITION (CAR SPEC) (THE LIST '(:LEFT :top :right :BOTTOM)) :TEST #'EQ) NSPEC) (CADR SPEC)))) (T (COPY-LIST SPEC)))) (DO ((SPEC SPEC (CDR SPEC)) (ITEM)) ((NULL SPEC)) (COND ((OR (NULL (SETQ ITEM (CAR SPEC))) (EQ ITEM :ZERO))) ;;A number means that width of the default function ((NUMBERP ITEM) (SETF (CAR SPEC) (CONS FUNCTION ITEM))) ;;A symbol means that function and its default width ((SYMBOLP ITEM) (AND (EQ ITEM T) (SETQ ITEM FUNCTION)) (SETF (CAR SPEC) (CONS ITEM (OR DEFAULT-SIZE (GET ITEM 'DEFAULT-BORDER-SIZE))))))) (DO ((SPEC SPEC (CDR SPEC)) (TYPES '(:LEFT :TOP :RIGHT :BOTTOM) (CDR TYPES)) (TYPE) (ITEM) (-WIDTH-)) ((NULL SPEC)) ;;A cons of a symbol and a number is the CAR function with the CDR width (AND (SETQ ITEM (CAR SPEC)) (CONSP ITEM) (SETQ -WIDTH- (CDR ITEM)) (IF (ATOM -WIDTH-) (SETF (CDR ITEM) (LIST (IF (EQ (SETQ TYPE (CAR TYPES)) :RIGHT) -WIDTH- 0) (IF (EQ TYPE :BOTTOM) -WIDTH- 0) (IF (EQ TYPE :LEFT) -WIDTH- 0) (IF (EQ TYPE :TOP) -WIDTH- 0))) ;;Else make entries relative (PROGN (SETQ TYPE (CAR TYPES)) (LET ((-WIDTH- (- (FOURTH ITEM) (SECOND ITEM))) (-HEIGHT- (- (FIFTH ITEM) (THIRD ITEM)))) (SETF (SECOND ITEM) (IF (EQ TYPE :RIGHT) -WIDTH- 0)) (SETF (THIRD ITEM) (IF (EQ TYPE :BOTTOM) -HEIGHT- 0)) (SETF (FOURTH ITEM) (IF (EQ TYPE :LEFT) -WIDTH- 0)) (SETF (FIFTH ITEM) (IF (EQ TYPE :TOP) -HEIGHT- 0))))))) ;;Now adjust all non-NIL items for the current margins (DO ((SPEC SPEC (CDR SPEC)) (TYPES '(:LEFT :TOP :RIGHT :BOTTOM) (CDR TYPES)) (TYPE) (ITEM) (-WIDTH-) (-HEIGHT-)) ((NULL SPEC)) (COND ((AND (SETQ ITEM (CAR SPEC)) (CONSP ITEM)) (SETQ TYPE (CAR TYPES)) (SETQ -WIDTH- (ABS (- (FOURTH ITEM) (SECOND ITEM))) -HEIGHT- (ABS (- (FIFTH ITEM) (THIRD ITEM)))) (COND ((CASE TYPE ((:LEFT :RIGHT) (ZEROP -WIDTH-)) ((:TOP :BOTTOM) (ZEROP -HEIGHT-))) (SETF (CAR SPEC) :ZERO)) (T ;; Order here is L R T B to give symmetry (SETF (SECOND ITEM) (IF (EQ TYPE :RIGHT) (- (+ (SECOND ITEM) RM)) (+ (SECOND ITEM) LM))) (SETF (FOURTH ITEM) (IF (EQ TYPE :LEFT) (+ (FOURTH ITEM) LM) (- (+ (FOURTH ITEM) RM)))) (SETF (THIRD ITEM) (IF (EQ TYPE :BOTTOM) (- (+ (THIRD ITEM) BM)) (+ (THIRD ITEM) TM))) (SETF (FIFTH ITEM) (IF (EQ TYPE :TOP) (+ (FIFTH ITEM) TM) (- (+ (FIFTH ITEM) BM)))) (CASE TYPE (:LEFT (SETQ LM (+ LM -WIDTH-))) (:TOP (SETQ TM (+ TM -HEIGHT-))) (:RIGHT (SETQ RM (+ RM -WIDTH-))) (:BOTTOM (SETQ BM (+ BM -HEIGHT-))))))))))) ;;Now allocate the border margin areas. (send self :compute-border-margin-area-margins spec lm tm rm bm)) ;;; SPR's 10144, 10136 - font can-t be determined when w:default-screen is nil in labels ;;; Patched LABEL-HEIGHT & (LABEL-MIXIN :LABEL-SIZE) & (LABEL-MIXIN :DRAW-LABEL) ;;; (DEFUN LABEL-HEIGHT (SHEET LABEL-STRING FONT &OPTIONAL LABEL-VSP) (COND ((NULL LABEL-STRING) ;Kludge patch for bug that label string may not be set up yet. (FONT-CHAR-HEIGHT (FONT-EVALUATE FONT sheet))) ;; may 10/25/89 (T (LET ((FONT (FONT-EVALUATE FONT sheet))) ;; may 10/25/89 (MULTIPLE-VALUE-BIND (NIL FINAL-Y) (SHEET-COMPUTE-MOTION SHEET 0 0 LABEL-STRING 0 NIL T 0 1.0S10 1.0S10 1.0S10 FONT (+ (OR LABEL-VSP 2) (FONT-CHAR-HEIGHT FONT))) FINAL-Y))))) (DEFMETHOD (LABEL-MIXIN :DRAW-LABEL) (SPEC LEFT TOP RIGHT BOTTOM) (AND SPEC (LET ((FONT (FONT-EVALUATE (LABEL-FONT SPEC) self)) ;; may 10/25/89 ) (prepare-color (self (label-color spec)) (SEND SELF (IF (LABEL-CENTERED SPEC) :STRING-OUT-CENTERED-EXPLICIT :STRING-OUT-EXPLICIT) (LABEL-STRING SPEC) LEFT TOP RIGHT BOTTOM FONT CHAR-ALUF 0 NIL (+ (OR (LABEL-VSP SPEC) 2) (FONT-CHAR-HEIGHT FONT))) )) )) (DEFMETHOD (LABEL-MIXIN :LABEL-SIZE) () (IF LABEL (LET ((FONT (FONT-EVALUATE (LABEL-FONT LABEL) self))) ;; may 10/25/89 (MULTIPLE-VALUE-BIND (NIL FINAL-Y NIL MAXIMUM-X) (SHEET-COMPUTE-MOTION SELF 0 0 (LABEL-STRING LABEL) 0 NIL T 0 1.0S10 1.0S10 1.0S10 FONT (+ (OR (LABEL-VSP LABEL) 2) (FONT-CHAR-HEIGHT FONT))) (VALUES MAXIMUM-X FINAL-Y))) (VALUES 0 0))) ;;; Fix bottom labels : ( if color and with non-zero :border-margin-width and NOT box-label-mixin ) (DEFUN ERASE-LABEL (&REST IGNORE) (DECLARE (:SELF-FLAVOR essential-LABEL-MIXIN)) (LET ((saveb (sheet-background-color self)) (newcolor (label-background label)) (color-system (color-system-p self))) (UNWIND-PROTECT (when LABEL (when color-system (SEND self :set-background-color (IF newcolor newcolor saveb))) (SHEET-FORCE-ACCESS (SELF) (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (COMPUTE-LABEL-POSITION) (PREPARE-SHEET (SELF) (let ((border-margin-width (and (send self :send-if-handles :really-boxed?) (send self :send-if-handles :border-margin-width))) (rect-height (- BOTTOM TOP))) ;; if there is boxing, stay just inside PMH 3/28/88 (when (AND (NEQ :DONT-FILL (SEND SELF :SEND-IF-HANDLES :REALLY-BOXED?)) ;; may 10/25/89 border-margin-width) (setf right (+ right border-margin-width) ;scoot out to the right left (- left border-margin-width) ; and the left ; rect-height (+ rect-height border-margin-width) ;and up/down ;; may 10/25/89 too soon! ) (when (plusp (label-top label)) ;which was it, up or down? + = top, - = bottom (setf top (- top border-margin-width))) ;it was up - shove it to top ;; may 10/25/89 Added below for labels on bottom (WHEN (MINUSP (LABEL-BOTTOM LABEL)) ;; may 10/25/89 (SETF BOTTOM (+ BOTTOM BORDER-MARGIN-WIDTH)));; may 10/25/89 it was up - shove it to top (SETQ RECT-HEIGHT (- BOTTOM TOP)) ;; may 10/25/89 compute using new top&bottom ) (%DRAW-RECTANGLE (- RIGHT LEFT) rect-height LEFT TOP ERASE-ALUF SELF)))))) (IF color-system (SEND self :set-background-color saveb))) )) ;;; Fix bottom labels : ( if NOT color, temporary, and with non-zero :border-margin-width and NOT box-label-mixin ) (DEFMETHOD (BOX-LABEL-MIXIN :AFTER :DRAW-LABEL) (SPEC LEFT TOP RIGHT BOTTOM) SPEC (prepare-color (self label-box-color) (AND LABEL-BOX-P (SHEET-FORCE-ACCESS (SELF) ;;; the reason we don't mess with reverse video in color is that we can color our menus ;;; and make them distinctive without using reverse video! (PREPARE-SHEET (SELF) ;; DRAW LABEL IN REVERSE-VIDEO ONLY IF TEMPORARY-WINDOW BASED on B&W system (if (AND (funcall self :temporary-bit-array) (NOT (color-system-p self))) ;; here is the extra test for color (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (COMPUTE-LABEL-POSITION) (let ((border-margin-width (and (send self :send-if-handles :really-boxed?) (send self :send-if-handles :border-margin-width))) (rect-height (- BOTTOM TOP))) ;; if there is boxing, blast up to the borders including margin region ;; PMH 3/28/88 (when (AND (NEQ :DONT-FILL (SEND SELF :SEND-IF-HANDLES :REALLY-BOXED?)) ;; may 10/25/89 border-margin-width) ;are we boxing? (setf right (+ right border-margin-width) ;include right margin area left (- left border-margin-width) ; and left margin area ;rect-height (+ rect-height border-margin-width) ;; may 10/25/89 too soon! ) (when (plusp top) ;is it top boxing? (setf top (- top border-margin-width))) ; yes, move up some ;; may 10/25/89 Added below for labels on bottom (WHEN (MINUSP (LABEL-BOTTOM LABEL)) ;; may 10/25/89 (SETF BOTTOM (+ BOTTOM BORDER-MARGIN-WIDTH)));; may 10/25/89 it was up - shove it to top (SETQ RECT-HEIGHT (- BOTTOM TOP)) ;; may 10/25/89 compute using new top&bottom ) (%DRAW-RECTANGLE (- RIGHT LEFT) rect-height LEFT TOP alu-xor SELF) )) ;; the following IS ORIGINAL DRAW-LABEL CODE (NO REVERSE-VIDEO) (let ((w (and (send self :send-if-handles :really-boxed?) (send self :send-if-handles :border-margin-width)))) (when (AND (NEQ :DONT-FILL (SEND SELF :SEND-IF-HANDLES :REALLY-BOXED?)) ;; may 10/25/89 w) (setq right (+ right w) left (- left w)))) (OR (>= BOTTOM (SHEET-INSIDE-BOTTOM)) (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT (1- BOTTOM) CHAR-ALUF SELF)) (OR (<= TOP (SHEET-INSIDE-TOP)) (%DRAW-RECTANGLE (- RIGHT LEFT) 1 LEFT (1- TOP) CHAR-ALUF SELF)))))))) )) ;; fix unreported bug : (send w:default-screen :set-reverse-video) #!C ; From file CSIB.LISP#> WINDOW; Hotel: #10R TV#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; CSIB.#" (defmethod (SCREEN :SET-REVERSE-VIDEO) () ; it seems logical that only the screen understands this message ; since individual sheets cannot be toggled. "Toggles Monochrome Video Polarity bit in Video Attribute Register" (send *control-register* :set-monochrome-polarity (- 1 (send *control-register* :monochrome-polarity)))) ))