;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Changed sheet-string-length to allow font descriptors, changed ;;; (sheet :string-out-explicit) to provide default args, and also ;;; changed sheet-string-out-explicit-1 to continue output until ;;; XLIM *AND* YLIM have beed reached for multiline strings. ;;; 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 05/16/89 11:49:07 by marky, ;;; while running on LIBRA from band LODA ;;; With SYSTEM 6.1, VIRTUAL-MEMORY 6.0, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; COMPILER 6.0, TV 6.1, DATALINK 6.0, CHAOSNET 6.0, GC 6.0, MEMORY-AUX 6.0, NVRAM 6.0, ;;; SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0, ;;; DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.0, SERIAL 6.0, PRINTER 6.0, MAC-PRINTER-TYPES 6.0, PRINTER-TYPES 6.0, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.0, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.0, TI-CLOS 6.0, CLEH 6.0, IP 3.45, ;;; Experimental BUG 11.4, Experimental CLX 6.0, Experimental CLUE 21.0, Experimental X11M 4.0, ;;; microcode 428, Band Name: Rel 6.0 + SLE 5/15 ;;; 05/16/89 MAY Changed SHEET-STRING-LENGTH to allow font descriptors. SPR 9275. ;;; The code tried to look af FONT in arglist before it could be coerced ;;; into a font object - just moved defualt arg down into code body. ;;; ;;; Also changed (SHEET :STRING-OUT-EXPLICIT) to provide default args. ;;; Changed SHEET-STRING-OUT-EXPLICIT-1 to keep on outputting text if ;;; string is multiline (has returns) and y-limit has NOT been reached. Before ;;; when x-limit was reached ALL output stopped. SPR 8242 #!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 SHEET-STRING-LENGTH (SHEET STRING &OPTIONAL (START 0) (END NIL) (STOP-X NIL) FONT (START-X 0) ;;; ( TAB-WIDTH ;; may 05/12/89 moved this below since font may not be parsed yet ;;; (IF FONT ;;; (* (FONT-CHAR-WIDTH FONT) (SHEET-TAB-NCHARS SHEET)) ;;; (SHEET-TAB-WIDTH SHEET))) &AUX (MAX-X START-X)) "Return the length in X-position of STRING or a portion. START and END specify the portion (default is all). START-X is an X-position to begin computation at. STOP-X is an X-position at which to stop processing and return. FINAL-INDEX will indicate where in the string this was reached. FONT is the font to use (default is SHEET's current font); but if STRING is an ART-FAT-STRING, each character's font is looked up in SHEET's font-map. TAB-WIDTH is the width to use for tab characters, defaulting to SHEET's SHEET-TAB-WIDTH. The cursor position does not wrap around during processing; arbitrarily large values can be returned. Use TV:SHEET-COMPUTE-MOTION if you want wrap-around. Three values are returned: FINAL-X is the X-position when processing stopped (due to end of string or portion, or reaching STOP-X). FINAL-INDEX is the index in the string at which processing stopped. MAXIMUM-X is the largest X-position reached during processing. This can be larger than FINAL-X if the string contains Backspaces or Returns." (DECLARE (VALUES FINAL-X FINAL-INDEX MAXIMUM-X)) (cond (FONT (COERCE-FONT FONT SHEET) (or tab-width (setq tab-width (* (FONT-CHAR-WIDTH FONT) (SHEET-TAB-NCHARS SHEET))))) ;; may 05/16/89 (t (SETQ FONT (SHEET-CURRENT-FONT SHEET)) (or tab-width (setq tab-width (SHEET-TAB-WIDTH SHEET))))) ;; may 05/16/89 (PROG (CWA CW CH FONTX TEM I N NN II STRINGP (X START-X)) (SETQ I START N (OR END (ARRAY-ACTIVE-LENGTH STRING)) CW (FONT-CHAR-WIDTH FONT)) ;At this point, decide whether we can use the fast version SLOW (AND (SETQ STRINGP (= (%P-MASK-FIELD-OFFSET %%ARRAY-TYPE-FIELD STRING 0) ART-STRING)) ;i.e. no font changes (NULL (SETQ CWA (FONT-CHAR-WIDTH-TABLE FONT)));and fixed width (GO FAST)) SLOW0 (OR (< I N) (RETURN X I MAX-X)) ;If string exhausted ;; Move quickly over 20 characters, or all the remaining characters, ;; if that does not go past STOP-X. (WHEN (OR STRINGP FONTX) (LET ((WIDTH-INCR (%STRING-WIDTH (OR CWA PRINTING-CHARACTER-TRANSLATE-TABLE) (IF FONTX (CODE-CHAR 0 0 FONTX) ;;(DPB FONTX %%CH-FONT 0) ;;ELSE 0) STRING I N (AND STOP-X (IF CWA (- STOP-X X) (FLOOR (- STOP-X X) CW)))))) (UNLESS CWA (SETQ WIDTH-INCR (* WIDTH-INCR CW))) (SETQ I (%POP)) (SETQ X (+ WIDTH-INCR X)) (SETQ MAX-X (MAX X MAX-X)) ;; Loop back if reached end of string. (IF (= I N) (GO SLOW0)))) ;; Otherwise we stopped due to funny character or font change or ;; reaching STOP-X. (SETQ CH (CHAR-CODE (SETQ TEM (AREF STRING I)))) (COND ((AND (NOT STRINGP) ;Changing fonts (NEQ (SETQ TEM (CHAR-FONT TEM)) FONTX)) (SETQ FONTX TEM FONT (AREF (SHEET-FONT-MAP SHEET) (IF (>= FONTX (ARRAY-ACTIVE-LENGTH (SHEET-FONT-MAP SHEET))) ; -GRH 0 FONTX)) CWA (FONT-CHAR-WIDTH-TABLE FONT) CW (FONT-CHAR-WIDTH FONT)))) (COND ((GRAPHIC-CHAR-P CH) ;Printing character (SETQ NN (IF CWA (AREF CWA CH) CW))) ((= CH #\TAB) (SETQ NN (IF (ZEROP (SETQ TEM TAB-WIDTH)) ; fix for zero tab width problem (dls). 0 ; fix for zero tab width problem (dls). (- (* (TRUNCATE (+ X TEM) TEM) TEM) X)))) ; fix for zero tab width problem (dls). ((AND (= CH #\BACKSPACE) (ZEROP (SHEET-BACKSPACE-NOT-OVERPRINTING-FLAG SHEET))) (SETQ NN (- (MAX 0 (- X (SHEET-CHAR-WIDTH SHEET))) X))) ((= CH #\NEWLINE) (SETQ NN 0 X 0)) (T ;Lozenged character (SETQ NN (SHEET-CHARACTER-WIDTH SHEET CH FONT)))) (SETQ X (+ X NN)) (IF (> X MAX-X) (SETQ MAX-X X)) (AND STOP-X (> X STOP-X) ;If char doesn't fit, stop before it (RETURN (- X NN) I MAX-X)) (SETQ I (1+ I)) (GO SLOW) ;; Here is the fast loop. The basic idea is to scan as fast as ;; possible over printing characters, with all checking outside the ;; loop. FAST ;; First, decide the most characters we want to scan over in a whack. (SETQ NN (COND ((NULL STOP-X) N) ;NN is limiting value of I ((MIN (+ (TRUNCATE (- STOP-X X) CW) I) N)))) ;; Now, scan over printing characters. ;; Save initial I, and check for null loop. (AND (>= (SETQ II I) NN) (GO SLOW0)) SCN (%STRING-WIDTH PRINTING-CHARACTER-TRANSLATE-TABLE 0 STRING II NN NIL) (SETQ I (%POP)) (SETQ X (+ (* (- I II) CW) X)) ;Account for the motion of those chars (IF (> X MAX-X) (SETQ MAX-X X)) ;Either string exhausted, non-printing, ; or reached stop-x (GO SLOW0))) ;;; may 05/16/89 ;;; Changed to provide sensible arg defaults for X-LIMIT Y-LIMIT FONT ALU and MULTI-LINE-LINE-HEIGHT ;;; and reduce work for caller. This lessens chance that output will be directed to draw ;;; outside window if defaults are used - there is nothing else to prevent it. (DEFMETHOD (SHEET :STRING-OUT-EXPLICIT) ;;; (STRING START-X START-Y X-LIMIT Y-LIMIT FONT ALU ;; may 05/16/89 ;;; &OPTIONAL (START 0) END MULTI-LINE-LINE-HEIGHT color) ;; may 05/16/89 (STRING &OPTIONAL ;; may 05/16/89 Provide default args for ALL 8 args below (START-X (sheet-inside-left self)) (START-Y (sheet-inside-top self)) (X-LIMIT (sheet-inside-right self)) (Y-LIMIT (sheet-inside-bottom self)) (FONT CURRENT-FONT) (ALU w:normal) (START 0) END (MULTI-LINE-LINE-HEIGHT (sheet-line-height self)) (color (if (color-sheet-p self) (sheet-foreground-color self) black))) (SHEET-STRING-OUT-EXPLICIT-1 SELF STRING START-X START-Y X-LIMIT Y-LIMIT FONT ALU START END MULTI-LINE-LINE-HEIGHT nil color)) ;;; may 05/16/89 Changed code & doc string (2 lines starting with UNLESS) ;;; to reflect new multi-line output change : If return characters are in STRING ;;; then the output does not stop at xlim - it is clipped - and continues on next ;;; line until YLIM is reached. ;;; (DEFUN SHEET-STRING-OUT-EXPLICIT-1 (SHEET STRING START-X Ypos XLIM YLIM FONT ALUF &OPTIONAL (START 0) (END NIL) MULTI-LINE-LINE-HEIGHT (ALIGN-FOR-LOZENGE NIL) color) "Output STRING on SHEET without using SHEET's cursor, font, etc. Output starts at cursor position START-X, Y but SHEET's cursor is not moved. Output of current line stops if x-position XLIM or y-position YLIM is reached unless RETURN characters are in string then portions of the string may be printed on subsequent lines, again clipping to XLIM, until YLIM is reached. Font FONT is used, and alu-function ALU. START and END specify a portion of STRING to be used. MULTI-LINE-LINE-HEIGHT is how far to move down for Return characters. Return also moves back to x-position START-X. NIL means output with a lozenge. All position arguments are relative to SHEET's outside edges." (DECLARE (VALUES FINAL-X FINAL-Y FINAL-INDEX)) (COERCE-FONT FONT SHEET) (prepare-color (sheet color) (PREPARE-SHEET (SHEET) (OR XLIM (SETQ XLIM (SHEET-WIDTH SHEET))) (LET* ((INDEX (OR START 0)) (END (OR END (ARRAY-ACTIVE-LENGTH STRING))) (XPOS start-x) CH) (WHEN (PLUSP (SHEET-RIGHT-MARGIN-CHARACTER-FLAG SHEET)) ;; Ensure enough room for ! at right of screen. (DECF XLIM (FONT-CHAR-WIDTH FONT))) (LOOP WHILE (< INDEX END) DOING (MULTIPLE-VALUE-SETQ (XPOS INDEX) (DRAW-STRING-INTERNAL SHEET STRING INDEX END xpos ypos XLIM FONT ALUF)) (UNLESS index ;Done? (RETURN xpos ypos end)) (SETQ CH (AREF STRING INDEX)) (COND ((AND MULTI-LINE-LINE-HEIGHT (= CH #\NEWLINE)) (SETQ Xpos START-X Ypos (+ Ypos MULTI-LINE-LINE-HEIGHT)) (INCF index) (IF (AND YLIM (> (+ Ypos MULTI-LINE-LINE-HEIGHT) YLIM)) (RETURN Xpos Ypos Index))) ((NOT (GRAPHIC-CHAR-P ch)) ;Special character? (LET ((STRING (LOZENGED-SPECIAL-CHAR-NAME CH)) NX) (MULTIPLE-VALUE-BIND (LOZENGE-WIDTH CORNER-WIDTH CORNER-HEIGHT) (LOZENGED-STRING-GEOMETRY STRING) (IF (> (SETQ NX (+ XPOS LOZENGE-WIDTH)) XLIM) (RETURN XLIM YLIM INDEX)) (SHEET-DISPLAY-LOZENGED-STRING-INTERNAL SHEET STRING XPOS (OR ALIGN-FOR-LOZENGE YPOS) XLIM ALUF LOZENGE-WIDTH CORNER-WIDTH CORNER-HEIGHT) (SETQ XPOS NX))) (INCF INDEX)) ;; may 05/16/89 Added this cond clause to allow continuing printing of string if ;; it has multi-lines (return chars) and YLIM has not been reached. ((and multi-line-line-height (find #\newline string :start index)) (setq xpos start-x ypos (+ ypos multi-line-line-height)) (setq index (+ 1 (position #\newline string :start index))) (if (and ylim (> (+ ypos multi-line-line-height) ylim)) (return xpos ypos index))) (T (RETURN XPOS YPOS END))) ; Else end of line FINALLY (RETURN xpos ypos end) ; KED 3/16/88 ))))) ))