;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Changes to make :draw-string-up (:draw-string-down) work for w:graphics-mixin ;;; and for windows with margins. ;;; 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 12/11/89 09:07:25 by MARKY, ;;; while running on LIBRA from band LODB ;;; With SYSTEM 6.26, VIRTUAL-MEMORY 6.3, 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.7, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.2, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2, ;;; SYSLOG 6.2, STREAMER-TAPE 6.5, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.8, ;;; DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.1, 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.4, MAIL-READER 6.6, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.6, TI-CLOS 6.26, CLEH 6.5, IP 3.56, ;;; Experimental CLX 6.7, Inconsistent CLUE 6.36, X11M 6.18, Experimental BUG 11.17, ;;; MMON 6.2, Experimental SC 2.0, Experimental CONFORMANCE-CHECKER 2.0, Experimental CLIO 10.0, ;;; Experimental CLIO-DEMO 2.0, microcode 429, Band Name: REL6-mmon-11/15/89 ;;; SPR 10788 ;;; 1. fix :string-out-up (:string-out-down) for w:graphics-mixin window. The :draw-point ;;; method converts the color to a gray scale on monochrome systems. If you want, as :Draw-string-up ;;; does, to convert an array of 0 & 1 values to fg & background values, you must use the ;;; same pixel values as the default = -1, or 0. ;;; 2. NOTE: :string-out-down does not take into consideration the margins. This is probably not noticed ;;; since margins are seldom used, but if margins were changes on a window, the placement of ;;; text would change for horizontal drawing but NOT for vertical drawing! The the documentation for ;;; tv:DRAW-CHAR-UP & tv:DRAW-CHAR-DOWN specifically say that the window's outside edges are used. ;;; But these functions use :read-cursopos as a default which returns x & y values relative to the ;;; INSIDE window edges. No matter which approach is taken the :String-out-up (down) method should work ;;; for the current cursorpos since x & y args are NOT available to be supplied, by this I mean the width ;;; of the borders should NOT influence the position of the string. Note that these functions also ;;; use :read-cursorpos if EITHER x or y is nil - this is crazy, too. Both problems are fixed below. ;;; 3. The result of window patch 6.6 is that the COLOR arg to :draw-point in w:graphic-mixin must be ;;; a 0 or -1 (default) and 1 will not work as anticipated on monchrome screens since the color 1 is translated ;;; to a non-solid gray scale color whereas -1 is translated to a ( solid ) gray-scale color - the desired effect. ;;; This is unfortunate but the gray-scale scheme requires that 1 just be the color between 0 and 2 and ;;; not the opposite of 0. A picture is worth a thousand words : (see below) ;(progn ; (dotimes (i (length w:b&w-table)) ; (format t "~2% For color ~d, array ~s is used which contains :~%~s" ; i (aref w:b&w-table i) (listarray (aref w:b&w-table i)))) ; (format t "~2% For color ~d, array ~s is used which contains :~%~s" ; -1 (aref w:b&w-table (mod -1 (length w:b&w-table))) ; (listarray (aref w:b&w-table (mod -1 (length w:b&w-table)))))) ; ; For color 0, array # is used which contains : ;(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) ; ; For color 1, array # is used which contains : ;(1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) ; ; For color 2, array # is used which contains : ;(1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1 0 0 0 1) ; ; For color 3, array # is used which contains : ;(1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1 0 0 1) ; ; For color 4, array # is used which contains : ;(0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0) ; ; For color 5, array # is used which contains : ;(0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0 1 1 0) ; ; For color 6, array # is used which contains : ;(0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0) ; ; For color 7, array # is used which contains : ;(0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ; ; For color 8, array # is used which contains : ;(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ; ; For color -1, array # is used which contains : ;(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) ;;; ;;; Note that w:black = 8 which is the same index as a translated -1 color ;;; and w:white = 0. #!C ; From file SHWARM.LISP#> WINDOW; sys: #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; SHWARM.#" (DEFUN SIMPLE-DRAW-CHAR-DOWN (FONT CHARACTER X Y ALU SHEET &optional (color (if (color-system-p sheet) (sheet-foreground-color sheet) -1))) "Draws a single character going down the window. Does NOT work when (si:mx-p)." ;; may 12/11/89 ;; Note that this is a simple version since it does not handle wide ;; fonts. We start drawing the characters at the position specified ;; by (X,Y). ;; ;; This function deals directly with the font array. Before trying to ;; understand what is going on here, it is important to read about the ;; font layout in the Window System manual. Only after that is done, ;; will the comments make sense. (LET* ((RASTERS-PER-WORD (FONT-RASTERS-PER-WORD FONT)) (HEIGHT (FONT-RASTER-HEIGHT FONT)) (WIDTH (FONT-RASTER-WIDTH FONT)) ;; amount of unused space in a word (WASTE (- 32 (* RASTERS-PER-WORD WIDTH))) (WORD-BASE (- ;; Compute the base index within the font of ;; where the character starts. Subtract from ;; the base index of the font, the waste and ;; width. They are subtracted because we are ;; going to add them back within the loop. (* 32 CHARACTER (FONT-WORDS-PER-CHAR FONT)) (+ WASTE WIDTH))) ;; This is a counter we are going to use to tell us when we ;; are going on to another 32 bit word. When this counter ;; gets up to RASTERS-PER-WORD then we are to start the next ;; word. (NEXT-WORD-COUNTER RASTERS-PER-WORD)) (DOTIMES (HEIGHT-INDEX HEIGHT) (SETQ WORD-BASE (+ WORD-BASE WIDTH (IF (= NEXT-WORD-COUNTER RASTERS-PER-WORD) ;; Starting on the next word. Adjust WORD-BASE so ;; that it starts on the index for the next word. (PROGN (SETQ NEXT-WORD-COUNTER 1) WASTE) (PROGN (INCF NEXT-WORD-COUNTER) 0)))) (DOTIMES (WIDTH-INDEX WIDTH) ;; Use DRAW-POINT because it performs clipping. (if (color-system-p sheet) (when (eql 1 (AREF FONT (+ WORD-BASE WIDTH-INDEX))) (SEND SHEET :DRAW-POINT (+ X (- HEIGHT HEIGHT-INDEX)) (+ Y WIDTH-INDEX) ALU color)) (SEND SHEET :DRAW-POINT (+ X (- HEIGHT HEIGHT-INDEX)) (+ Y WIDTH-INDEX) ALU (if (zerop (AREF FONT (+ WORD-BASE WIDTH-INDEX))) 0 -1) ;; may 11/20/89 )))))) )) #!C ; From file SHWARM.LISP#> WINDOW; Sys: #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; SHWARM.#" (DEFUN SIMPLE-DRAW-CHAR-UP (FONT CHARACTER X Y ALU SHEET &optional (color (if (color-system-p sheet) (sheet-foreground-color sheet) -1))) "Draws a single character going up the window. Does NOT work when (si:mx-p)." ;; may 12/11/89 ;; Note that this is a simple version since it does not handle wide ;; fonts. We start drawing the characters at the position specified ;; by (X,Y). ;; ;; This function deals directly with the font array. Before trying to ;; understand what is going on here, it is important to read about ;; the font layout in the Window System manual. Only after that is ;; done, will the comments make sense. (LET* ((RASTERS-PER-WORD (FONT-RASTERS-PER-WORD FONT)) (HEIGHT (FONT-RASTER-HEIGHT FONT)) (WIDTH (FONT-RASTER-WIDTH FONT)) ;; Amount of unused space in a word. (WASTE (- 32 (* RASTERS-PER-WORD WIDTH))) (WORD-BASE (- ;; Compute the base index within the font of ;; where the character starts. Subtract from ;; the base index of the font, the waste and ;; width. They are subtracted because we are ;; going to add them back within the loop. (* 32 CHARACTER (FONT-WORDS-PER-CHAR FONT)) (+ WASTE WIDTH))) ;; This is a counter we are going to use to tell us when we ;; are going on to another 32 bit word. When this counter ;; gets up to RASTERS-PER-WORD then we are to start the next ;; word. (NEXT-WORD-COUNTER RASTERS-PER-WORD)) (DOTIMES (HEIGHT-INDEX HEIGHT) (SETQ WORD-BASE (+ WORD-BASE WIDTH (IF (= NEXT-WORD-COUNTER RASTERS-PER-WORD) ;; Starting on the next word. Adjust WORD-BASE so ;; that it starts on the index for the next word. (PROGN (SETQ NEXT-WORD-COUNTER 1) WASTE) (PROGN (INCF NEXT-WORD-COUNTER) 0)))) (DOTIMES (WIDTH-INDEX WIDTH) ;; Use DRAW-POINT because it performs clipping. (if (color-system-p sheet) (when (eql 1 (AREF FONT (+ WORD-BASE WIDTH-INDEX))) (SEND SHEET :DRAW-POINT (+ X HEIGHT-INDEX) (- Y WIDTH-INDEX); We are going up, so subtract. ALU color)) (SEND SHEET :DRAW-POINT (+ X HEIGHT-INDEX) (- Y WIDTH-INDEX); We are going up, so subtract. ALU (if (zerop (AREF FONT (+ WORD-BASE WIDTH-INDEX))) 0 -1) ;; may 11/20/89 )))))) )) #!C ; From file SHWARM.LISP#> WINDOW; Sys: #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; SHWARM.#" (DEFUN DRAW-CHAR-UP (FONT CHARACTER &OPTIONAL (X NIL) (Y NIL) (ALU NIL) (SHEET SELECTED-WINDOW) (color (if (color-system-p sheet) (sheet-foreground-color sheet) -1))) "Draw character CHARACTER in FONT at X, Y in SHEET using alu-function ALU. X and Y are relative to SHEET's outside edges. Does NOT work when (si:mx-p)." ;; may 12/11/89 (UNLESS ALU (SETQ ALU ALU-XOR)) (COERCE-FONT FONT SHEET) (LET ((FIT (FONT-INDEXING-TABLE FONT))) ;; Start at the current cursor position. (MULTIPLE-VALUE-BIND (X Y) ;; may 11/20/89 Start patch - make default be relative to OUTSIDE edges as documented ;; so that margin widths do not affect drawing - :read-cursopos is relative and ignores margins ;(IF (OR (NULL X) (NULL Y)) ;(SEND SHEET :READ-CURSORPOS) ;(VALUES X Y)) (values (or x (sheet-cursor-x sheet)) ;; may 11/20/89 (or y (sheet-cursor-y sheet))) ;; may 11/20/89 END PATCH (IF FIT (DO ((CHARACTER (AREF FIT CHARACTER) (1+ CHARACTER)) (LIM (AREF FIT (1+ CHARACTER))) (BPP (IF (ARRAYP SHEET) (ARRAY-BITS-PER-PIXEL SHEET) (SHEET-BITS-PER-PIXEL SHEET))) (Y Y (- Y (TRUNCATE (FONT-RASTER-WIDTH FONT) BPP)))) ((>= CHARACTER LIM)) (SIMPLE-DRAW-CHAR-UP FONT CHARACTER X Y ALU SHEET color)) (SIMPLE-DRAW-CHAR-UP FONT CHARACTER X Y ALU SHEET color))))) )) #!C ; From file SHWARM.LISP#> WINDOW; Sys: #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; SHWARM.#" (DEFUN DRAW-CHAR-DOWN (FONT CHARACTER &OPTIONAL (X NIL) (Y NIL) (ALU NIL) (SHEET SELECTED-WINDOW) (color (if (color-system-p sheet) (sheet-foreground-color sheet) -1))) "Draw character CHARACTER in FONT at X, Y in SHEET using alu-function ALU. X and Y are relative to SHEET's outside edges. Does NOT work when (si:mx-p)." ;; may 12/11/89 (UNLESS ALU (SETQ ALU ALU-XOR)) (COERCE-FONT FONT SHEET) (LET ((FIT (FONT-INDEXING-TABLE FONT))) ;; Start at the current cursor position. (MULTIPLE-VALUE-BIND (X Y) ;; may 11/20/89 Start patch - make default be relative to OUTSIDE edges as documented ;; so that margin widths do not affect drawing - :read-cursopos is relative and ignores margins ;(IF (OR (NULL X) (NULL Y)) ;(SEND SHEET :READ-CURSORPOS) ;(VALUES X Y)) (values (or x (sheet-cursor-x sheet)) ;; may 11/20/89 (or y (sheet-cursor-y sheet))) ;; may 11/20/89 END PATCH (IF FIT (DO ((CHARACTER (AREF FIT CHARACTER) (1+ CHARACTER)) (LIM (AREF FIT (1+ CHARACTER))) (BPP (IF (ARRAYP SHEET) (ARRAY-BITS-PER-PIXEL SHEET) (SHEET-BITS-PER-PIXEL SHEET))) (Y Y (+ Y (TRUNCATE (FONT-RASTER-WIDTH FONT) BPP)))) ((>= CHARACTER LIM)) (SIMPLE-DRAW-CHAR-DOWN FONT CHARACTER X Y ALU SHEET color)) (SIMPLE-DRAW-CHAR-DOWN FONT CHARACTER X Y ALU SHEET color))))) ))