;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Patch-file:T -*- ;;; Written 07/06/89 13:02:48 by GRENINGER, ;;; Reason: Protect all calls on mX (send-xxx ...) routines by wrapping them within either ;;; without-interrupts (blinkers) or prepare-sheet (everything else). This should ;;; ensure that inhibit-scheduling-flag is always T when we bind add:*no-interrupt* ;;; before sending a drawing command to the Mac, resulting in much improved stability. ;;; [SPR 10194] ;;; while running on MX23 from band g629 ;;; With SYSTEM 6.10, GC 6.3, VIRTUAL-MEMORY 6.1, MICRONET 6.0, MICRONET-COMM 6.1, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-PATHNAME 6.0, MAC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, ;;; BASIC-NAMESPACE 6.1, BASIC-FILE 6.2, RPC 6.1, NFS-MX 6.0, EH 6.3, MAKE-SYSTEM 6.0, ;;; MEMORY-AUX 6.0, COMPILER 6.6, TV 6.12, NVRAM 6.1, UCL 6.0, INPUT-EDITOR 6.0, ;;; MACTOOLBOX 2.3, METER 6.1, ZWEI 6.3, Experimental DEBUG-TOOLS 6.3, Inconsistent WINDOW-MX 6.5, ;;; PRINTER 6.2, MAC-PRINTER-TYPES 6.1, CLIPBOARD 6.0, TI-CLOS 6.10, CLEH 6.4, NETWORK-PATHNAME 6.0, ;;; NETWORK-NAMESPACE 6.0, DATALINK 6.0, CHAOSNET 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, ;;; DATALINK-DISPLAYS 6.0, MX-DATALINK 6.1, NAMESPACE-EDITOR 6.0, IP 3.47, NFS-MX-SERVER 6.0, ;;; MX-SERIAL 6.0, PRINTER-TYPES 6.0, IMAGEN 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, ;;; TELNET 6.0, VT100 6.0, STREAMER-TAPE 6.3, DECNET 1.69, VISIDOC 6.2, PROFILE 6.1, ;;; microcode 138, Band Name: microExplorer Network (6/22) #!C ; From file SCRED2.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; SCRED2.#" (DEFMETHOD (FOLLOWING-ARROW-BLINKER :BLINK) (&AUX X0 Y0 X2 Y2 X3 Y3 X4 Y4 X5 Y5 X6 Y6 X7 Y7) "Draw the following-arrow blinker." ;; The arrow is actually drawn as a series of 5 filled triangles each ;; having the point of the arrow as a common point. The figure below ;; shows each of the 5 filled triangles that are drawn. The 6 ;; vertices are labelled with digits 2-7 and the letters A-E indicate ;; the part shaded in by a particular filled triangle. The vertices ;; of the 5 triangles that are drawn are: ;; ;; A -- 2 4 CENTER ;; B -- 4 6 CENTER ;; C -- 6 7 CENTER ;; D -- 7 5 CENTER ;; E -- 5 3 CENTER ;; ;; 2 ;; |\ ;; |AA\ ;; |AAAA\ ;; 6 4 |AAAAAA\ ;; .-----------------------------'AAAAAAAA\ ;; |CCCCCCCCCCCCCC BBBBBBBBBBBBBBBBB AAAAAAA\ ;; |CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC BBBBBBB AAA\ ;; |CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC> CENTER ;; |CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DDDDDDD EEE/ ;; |CCCCCCCCCCCCCC DDDDDDDDDDDDDDDDD EEEEEEE/ ;; `-----------------------------.EEEEEEEE/ ;; 7 5 |EEEEEE/ ;; |EEEE/ ;; |EE/ ;; |/ ;; 3 ;; The reason for drawing the arrow in this fashion is to make certain ;; that a solid arrow is drawn for every case. An optimization of ;; this case is to only draw 3 triangles (for example, (2 3 CENTER), ;; (4 5 6) and (5 6 7)). For this optimization there are cases where ;; there is a gap near vertex 4 or vertex 5, making the arrow contain ;; a crack. Therefore, we draw the arrow by drawing 5 triangles. ;; The digits of the vertices were chosen to match with the variable ;; names used in the code. The vertex 2 corresponds to the point ;; (X2,Y2), the vertex 3 corresponds to the point (X3,Y3), etc. (COND ((NOT PHASE) ;;Making it visible, recompute the vertices. (LET (DX DY LEN) (SETQ X0 (OR X-ORIGIN X-POS)) (SETQ Y0 (OR Y-ORIGIN Y-POS)) (SETQ DX (- X-POS X0) DY (- Y-POS Y0) LEN (ISQRT (+ (* DX DX) (* DY DY)))) (AND (ZEROP LEN) ;Right on top of where it's pointing (COND ((NULL X-ORIGIN) ;Straight up (SETQ DY 1 LEN 1)) ((NULL Y-ORIGIN) ;Straight left (SETQ DX 1 LEN 1)) (T (SETQ DX 1 DY 1 LEN 1)))) ;Top-left corner (SETQ X4 (+ X-POS (TRUNCATE (* DX TRI-HEIGHT) LEN)) Y4 (+ Y-POS (TRUNCATE (* DY TRI-HEIGHT) LEN)) X6 (+ X-POS (TRUNCATE (* DX (+ TRI-HEIGHT RECT-HEIGHT)) LEN)) Y6 (+ Y-POS (TRUNCATE (* DY (+ TRI-HEIGHT RECT-HEIGHT)) LEN))) (LET ((DX1 (TRUNCATE (* TRI-WIDTH DY) LEN)) (DY1 (TRUNCATE (* TRI-WIDTH DX) LEN))) (SETQ X2 (- X4 DX1) Y2 (+ Y4 DY1) X3 (+ X4 DX1) Y3 (- Y4 DY1))) (LET ((DX1 (TRUNCATE (* RECT-WIDTH DY) LEN)) (DY1 (TRUNCATE (* RECT-WIDTH DX) LEN))) (SETQ X5 (+ X4 DX1) Y5 (- Y4 DY1) X4 (- X4 DX1) Y4 (+ Y4 DY1)) (SETQ X7 (+ X6 DX1) Y7 (- Y6 DY1) X6 (- X6 DX1) Y6 (+ Y6 DY1)))) (SETF (NTH 0 STATE) X2) (SETF (NTH 1 STATE) Y2) (SETF (NTH 2 STATE) X3) (SETF (NTH 3 STATE) Y3) (SETF (NTH 4 STATE) X4) (SETF (NTH 5 STATE) Y4) (SETF (NTH 6 STATE) X5) (SETF (NTH 7 STATE) Y5) (SETF (NTH #o10 STATE) X6) (SETF (NTH #o11 STATE) Y6) (SETF (NTH #o12 STATE) X7) (SETF (NTH #o13 STATE) Y7)) (T ;;Erasing it, use old parameters (SETQ X2 (NTH 0 STATE)) (SETQ Y2 (NTH 1 STATE)) (SETQ X3 (NTH 2 STATE)) (SETQ Y3 (NTH 3 STATE)) (SETQ X4 (NTH 4 STATE)) (SETQ Y4 (NTH 5 STATE)) (SETQ X5 (NTH 6 STATE)) (SETQ Y5 (NTH 7 STATE)) (SETQ X6 (NTH #o10 STATE)) (SETQ Y6 (NTH #o11 STATE)) (SETQ X7 (NTH #o12 STATE)) (SETQ Y7 (NTH #o13 STATE)))) ;;; >>> change to mouse alu for color system (IF (mac-window-p sheet) (WITHOUT-INTERRUPTS ; must protect all mX (send-xxx functions... (WITH-STACK-LIST (x-coords x-pos x2 x4 x6 x7 x5 x3) (WITH-STACK-LIST (y-coords y-pos y2 y4 y6 y7 y5 y3) (send-draw-filled-polygon x-coords y-coords (mouse-alu phase) w:black sheet nil)))) ;; else... (SYSTEM:%DRAW-shaded-TRIANGLE X-POS Y-POS X2 Y2 X4 Y4 (mouse-alu phase) t t nil nil SHEET) (SYSTEM:%DRAW-shaded-TRIANGLE X-POS Y-POS X4 Y4 X6 Y6 (mouse-alu phase) t t nil nil SHEET) (SYSTEM:%DRAW-shaded-TRIANGLE X-POS Y-POS X6 Y6 X7 Y7 (mouse-alu phase) t t nil nil SHEET) (SYSTEM:%DRAW-shaded-TRIANGLE X-POS Y-POS X7 Y7 X5 Y5 (mouse-alu phase) t t nil nil SHEET) (SYSTEM:%DRAW-shaded-TRIANGLE X-POS Y-POS X5 Y5 X3 Y3 (mouse-alu phase) t t nil nil SHEET)) ) )) #!C ; From file BLINKERS.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; BLINKERS.#" (DEFMETHOD (HOLLOW-RECTANGULAR-BLINKER :BLINK) () (LET ((-X-POS- (1- X-POS)) (-Y-POS- (1- Y-POS)) (-HEIGHT- (1+ HEIGHT)) (-WIDTH- (1+ WIDTH))) (IF (mac-window-p sheet) (LET ((*dont-clip-at-the-margins* t) (inhibit-scheduling-flag t)) (send-DrawHollowRectangle -x-pos- -y-pos- -width- -height- 1 w:black (MOUSE-ALU PHASE) sheet)) ;; else... (%DRAW-RECTANGLE-CLIPPED 1 -HEIGHT- -X-POS- -Y-POS- (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED (- -WIDTH- 1) 1 (+ -X-POS- 1) -Y-POS- (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED 1 (- -HEIGHT- 1) (+ -X-POS- -WIDTH- -1) (+ -Y-POS- 1) (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED (- -WIDTH- 2) 1 (+ -X-POS- 1) (+ -Y-POS- -HEIGHT- -1) (MOUSE-ALU PHASE) SHEET)))) )) #!C ; From file BLINKERS.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; BLINKERS.#" (DEFMETHOD (BOX-BLINKER :BLINK) () (IF (mac-window-p sheet) (LET ((*dont-clip-at-the-margins* t) (inhibit-scheduling-flag t)) (send-drawhollowrectangle x-pos y-pos width height 2 w:black (mouse-alu phase) sheet)) ;; else... (%DRAW-RECTANGLE-CLIPPED 2 HEIGHT X-POS Y-POS (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED (- WIDTH 2) 2 (+ X-POS 2) Y-POS (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED 2 (- HEIGHT 2) (+ X-POS WIDTH -2) (+ Y-POS 2) (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED (- WIDTH 4) 2 (+ X-POS 2) (+ Y-POS HEIGHT -2) (MOUSE-ALU PHASE) SHEET))) ;Mixin that causes a blinker to stay entirely inside its sheet )) #!C ; From file BLINKERS.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; BLINKERS.#" (DEFMETHOD (MAGNIFYING-BLINKER :BEFORE :BLINK) () ;; (:method BLINKER :BEFORE :BLINK) is called AFTER (:method MAGNIFYING-BLINKER :BEFORE :BLINK) ;; But we need to change the order. This is impossible without major changes ;; so we will just call (BLINKER :BEFORE :BLINK) - or its guts (before-blinker-blink) - twice. ;; Once now and once in (BLINKER :BEFORE :BLINK) - only the first call is necessary ;; and the second call will not hurt. (before-blinker-blink) ;; may 02/22/89 (LET* ((SCREEN-ARRAY (SHEET-SCREEN-ARRAY SHEET)) (SWIDTH (tv:sheet-inside-right sheet)) ;; may 02/21/89 swidth is NOT a width but sheet-inside-right! (SHEIGHT (tv:sheet-inside-bottom sheet)) ;; may 02/21/89 (-x-pos- (MIN x-pos (- swidth width))) ;; max cursor x-pos inside window (-y-pos- (MIN y-pos (- sheight height))) ;; max cursor y-pos inside window ;; FROM-xxxx variables are used to filter out 0 width/height bitblts that ;; mac complains about. (from-x (+ (TRUNCATE (- x-offset) magnification) x-offset -x-pos-)) ;; may 04/18/89 (from-y (+ (TRUNCATE (- y-offset) magnification) y-offset -y-pos-)) ;; may 04/18/89 (from-width (MIN (CEILING width magnification) (- swidth from-x))) (from-height (MIN (CEILING height magnification) (- sheight from-y))) (background-color (IF (color-system-p sheet) (tv:sheet-background-color sheet) w:white))) ;; OK, what we are doing is this : ;; 1. The source-array can be the screen-array on the Explorer ;; but it must be a copy of the screen for the MAC - it does ;; not support direct access to its screen array. ;; 2. magnify the source-array into instance variable ARRAY ;; 3. BITBLT source-array to ARRAY using alu-sub. This will merge ;; the magnified image with a reverse immage of the screen so ;; that when the :blink method blt's ARRAY to the screen the ;; former text will be wiped out and the magnified image will ;; be all that remains. NOTE: on a b&w monitor either mouse-alu ;; alu-add or alu-sub gets converted to alu-xor. On a color system ;; we MUST get the alu-sub. Thus we use (mouse-alu (not phase)). (WHEN (AND (NULL phase) (NOT (ZEROP from-height)) (NOT (ZEROP from-width))) ;; Since aref's of the screen are too expensive on MAC - just ;; blt the screen array portion into local copy and then magnify from local-copy. (BITBLT tv:alu-seta from-width from-height screen-array from-x from-y local-copy 0 0) ;; Init array for speed to background color, then change any element /= to background (ARRAY-INITIALIZE ARRAY background-color) ;; may 02/21/89 (WHEN SCREEN-ARRAY (LOOP with tem for i from 0 for i1 from 0 below width by magnification do (LOOP for j from 0 for j1 from 0 below height by magnification do (WHEN (/= background-color (SETQ tem (AREF local-copy j i))) (DOTIMES (i2 magnification) (DOTIMES (j2 magnification) (SETF (AREF array (+ j1 j2) (+ i1 i2)) tem)))))) ;; may 02/22/89 Changed similarly to (:method BITBLT-BLINKER :BLINK) ;; Do not go into margins with blinker - necessary for magnifing blinker ;; since areas near margins cannot be magnified-viewed. ;; Changed to arg to mouse-alu from PHASE to T - phase is nil here. ;; This makes color work better. (BITBLT (MOUSE-ALU (NOT PHASE)) ;; may 02/23/89 width height SCREEN-ARRAY -x-pos- -y-pos- ARRAY 0 0 ))) ;; Make a box AROUND the whole thing so it can be found if screen is ;; blank under it. ;; We ALWAYS draw the rectangle on the screen. (LET ((-X-POS- (+ -X-POS- -1)) ; note -x-pos- (-Y-POS- (+ -Y-POS- -1)) ; note -y-pos- (-HEIGHT- (+ 2 HEIGHT)) (-WIDTH- (+ 2 WIDTH))) (IF (mac-window-p sheet) ;; *dont-clip-at-the-margins* T is probably not needed ;; since blinker does NOT go into margins anymore ? (LET ((*dont-clip-at-the-margins* t) (inhibit-scheduling-flag t)) (send-drawhollowrectangle -x-pos- -y-pos- -width- -height- 1 w:black (mouse-alu phase) sheet)) ;; else... (%DRAW-RECTANGLE-CLIPPED 1 -HEIGHT- -X-POS- -Y-POS- (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED (- -WIDTH- 1) 1 (+ -X-POS- 1) -Y-POS- (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED 1 (- -HEIGHT- 1) (+ -X-POS- -WIDTH- -1) (+ -Y-POS- 1) (MOUSE-ALU PHASE) SHEET) (%DRAW-RECTANGLE-CLIPPED (- -WIDTH- 2) 1 (+ -X-POS- 1) (+ -Y-POS- -HEIGHT- -1) (MOUSE-ALU PHASE) SHEET))))) )) #!C ; From file STREAM.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; STREAM.#" (DEFMETHOD (GRAPHICS-MIXIN :DRAW-POINT) (X Y &OPTIONAL (ALU CHAR-ALUF) (color (sheet-foreground-color self))) ;;; -1 was the old optional value before color, preserve it for b&w operations. ;;; NOTE: new ALUs were added for color, but are not understood by the BOOLE function, so we ;;; have to handle them properly. ;;; This looks slow compared to the old, but its actually quite fast... (SETQ X (+ X (SHEET-INSIDE-LEFT)) Y (+ Y (SHEET-INSIDE-TOP))) (UNLESS (OR (< X (SHEET-INSIDE-LEFT)) (>= X (SHEET-INSIDE-RIGHT)) (< Y (SHEET-INSIDE-TOP)) (>= Y (SHEET-INSIDE-BOTTOM))) (PREPARE-SHEET (SELF) (IF (mac-window-p self) (with-clipping-rectangle (0 0 width height) (send-draw-point x y alu (IF (color-system-p self) color (IF (ZEROP color) w:white w:black)) self)) ;; else (LET ((current (AREF screen-array y x)) (the-color-map (sheet-color-map self)) (background (sheet-background-color self))) (unless (color-system-p self) (cond ; have to translate to monochrome equivalents ((= alu alu-back) (setf alu alu-andca)) ((= alu alu-transp) (setf alu alu-ior)) ((= alu alu-add) (setf alu alu-xor)) ((= alu alu-sub) (setf alu alu-xor)) ((= alu alu-max) (setf alu alu-ior)) ((= alu alu-min) (setf alu alu-and)) ((= alu alu-avg) (setf alu alu-ior)) ((= alu alu-adds) (setf alu alu-ior)) ((= alu alu-subc) (setf alu alu-andca)) ) ) (COND ((= alu alu-back) (SETF (AREF screen-array y x) background)) ((= alu alu-transp) (SETF (AREF screen-array y x) color)) ((= alu alu-add) (SETF (AREF screen-array y x) (mod (+ color current) 256))) ((= alu alu-sub) (SETF (AREF screen-array y x) (mod (- current color) 256))) ((= alu alu-max) (SETF (AREF screen-array y x) (max color current))) ((= alu alu-min) (SETF (AREF screen-array y x) (min color current))) ((= alu alu-avg) (SETF (AREF screen-array y x) (truncate (+ color current) 2))) ((= alu alu-adds) (SETF (AREF screen-array y x) (min (+ color current) (color-map-saturate the-color-map)))) ((= alu alu-subc) (SETF (AREF screen-array y x) (max (- current color) (color-map-clamp the-color-map)))) (t (setf (aref screen-array y x) (boole alu color current))) )))))) ;;; The following function returns a mask which indicates where the (X,Y) ;;; point is located relative to the edges of the window. The following ;;; diagram shows the binary mask value returned if the (X,Y) point were ;;; located where the number is located. For example, if the (X,Y) ;;; point were located to the left and down from the window then the ;;; mask returned would be 1001. ;;; ;;; 0101 0110 ;;; 0100 ;;; ;;; .-----------------. ;;; | | ;;; | | ;;; | | ;;; 0001 | 0000 | 0010 ;;; | | ;;; | | ;;; | | ;;; `-----------------' ;;; ;;; 1000 ;;; 1001 1010 ;;; )) #!C ; From file STREAM.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; STREAM.#" (DEFMETHOD (GRAPHICS-MIXIN :DRAW-LINE) (FROM-X FROM-Y TO-X TO-Y &OPTIONAL (ALU CHAR-ALUF) (DRAW-END-POINT T) (color (IF (color-system-p self) (sheet-foreground-color self) -1))) (SETQ FROM-X (+ FROM-X (SHEET-INSIDE-LEFT)) FROM-Y (+ FROM-Y (SHEET-INSIDE-TOP)) TO-X (+ TO-X (SHEET-INSIDE-LEFT)) TO-Y (+ TO-Y (SHEET-INSIDE-TOP))) (prepare-color (self color) (PREPARE-SHEET (SELF) (IF (mac-window-p self) (with-clipping-rectangle (0 0 width height) (send-draw-line from-x from-y to-x to-y alu draw-end-point self t 1 (IF (color-system-p self) color (IF (ZEROP color) w:white w:black))) (UNLESS draw-end-point ; Turn off end point. (send-draw-point to-x to-y w:alu-xor w:black self))) ;; else... (DO ((FROM-VISIBILITY (DRAW-LINE-CLIP-VISIBILITY FROM-X FROM-Y) (DRAW-LINE-CLIP-VISIBILITY FROM-X FROM-Y)) (TO-VISIBILITY (DRAW-LINE-CLIP-VISIBILITY TO-X TO-Y)) (EXCHANGED NIL)) ;;When completely visible, draw the line ((AND (ZEROP FROM-VISIBILITY) (ZEROP TO-VISIBILITY)) (AND EXCHANGED (PSETQ FROM-X TO-X TO-X FROM-X FROM-Y TO-Y TO-Y FROM-Y)) (SYS:%DRAW-SHADED-TRIANGLE FROM-X FROM-Y TO-X TO-Y TO-X TO-Y ALU T DRAW-END-POINT T NIL SELF) ) ;; If all off the screen, dont draw anything. (OR (ZEROP (LOGAND FROM-VISIBILITY TO-VISIBILITY)) (RETURN NIL)) ;; Exchange points to try to make to point visible. (AND (ZEROP FROM-VISIBILITY) (PSETQ FROM-X TO-X TO-X FROM-X FROM-Y TO-Y TO-Y FROM-Y FROM-VISIBILITY TO-VISIBILITY TO-VISIBILITY FROM-VISIBILITY EXCHANGED (NOT EXCHANGED))) ;; If TO-X = FROM-X then FROM-VISIBILITY = 0, 4 or 8 so there is no ;; danger of divide by zero in the next "Push". (COND ((LDB-TEST (BYTE 1 0) FROM-VISIBILITY) ;Push toward left edge (SETQ FROM-Y (+ FROM-Y (TRUNCATE (* (- TO-Y FROM-Y) (- (SHEET-INSIDE-LEFT) FROM-X)) (- TO-X FROM-X))) FROM-X (SHEET-INSIDE-LEFT))) ((LDB-TEST (BYTE 1 1) FROM-VISIBILITY) ;Push toward right edge (SETQ FROM-Y (+ FROM-Y (TRUNCATE (* (- TO-Y FROM-Y) (- (SHEET-INSIDE-RIGHT) FROM-X 1)) (- TO-X FROM-X))) FROM-X (1- (SHEET-INSIDE-RIGHT))))) (COND ((LDB-TEST (BYTE 1 2) FROM-VISIBILITY) ;Push toward top ;; It is possible that TO-Y = FROM-Y at this point because of ;; the effects of the last "Push", but in that case TO-X is ;; probably equal to FROM-X as well (or at least close to it) ;; so we needn't draw anything: (AND (= TO-Y FROM-Y) (RETURN NIL)) (SETQ FROM-X (+ FROM-X (TRUNCATE (* (- TO-X FROM-X) (- (SHEET-INSIDE-TOP) FROM-Y)) (- TO-Y FROM-Y))) FROM-Y (SHEET-INSIDE-TOP))) ((LDB-TEST (BYTE 1 3) FROM-VISIBILITY) ;Push toward bottom ;; Same: (AND (= TO-Y FROM-Y) (RETURN NIL)) (SETQ FROM-X (+ FROM-X (TRUNCATE (* (- TO-X FROM-X) (- (SHEET-INSIDE-BOTTOM) FROM-Y 1)) (- TO-Y FROM-Y))) FROM-Y (1- (SHEET-INSIDE-BOTTOM)))))))))) ;;; This never draws any end points, thus it is good for making closed ;;; polygons. Calls the :DRAW-LINE method to do the clipping. ;;; Hack alert: note that we will allow a color argument in a "keyword-like" ;;; syntax; lets just say the :color keyword argument must follow the X and Y pairs. )) #!C ; From file STREAM.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; STREAM.#" (DEFMETHOD (GRAPHICS-MIXIN :DRAW-CIRCLE) (CENTER-X CENTER-Y RADIUS &OPTIONAL (ALU CHAR-ALUF) (color (if (color-system-p self)(sheet-foreground-color self) 1))) (LET* ((IL (SHEET-INSIDE-LEFT)) (IT (SHEET-INSIDE-TOP)) (IR (SHEET-INSIDE-RIGHT)) (IB (SHEET-INSIDE-BOTTOM)) (CENTER-X (+ CENTER-X IL)) (CENTER-Y (+ CENTER-Y IT))) (PREPARE-SHEET (SELF) (IF (mac-window-p self) (with-clipping-rectangle (0 0 width height) (send-DrawHollowCircle center-x center-y radius 1 (IF (color-system-p self) color (IF (ZEROP color) w:white w:black)) alu 29 self)) ;; else... (DO ((Y 0) (X-VAL) (Y-VAL) (F 0) ; F is just Y squared without any multiplies (X RADIUS)) (NIL) (DRAW-CLIPPED-POINT (+ CENTER-X X) (- CENTER-Y Y) color alu) (DRAW-CLIPPED-POINT (- CENTER-X X) (+ CENTER-Y Y) color alu) (DRAW-CLIPPED-POINT (+ CENTER-X Y) (+ CENTER-Y X) color alu) (DRAW-CLIPPED-POINT (- CENTER-X Y) (- CENTER-Y X) color alu) (SETQ F (+ F Y Y 1) Y (1+ Y)) (COND ((>= F X) (SETQ F (- F X X -1) X (- X 1)))) (COND ((> Y X) (RETURN))) (DRAW-CLIPPED-POINT (+ CENTER-X X) (+ CENTER-Y Y) color alu) (DRAW-CLIPPED-POINT (- CENTER-X X) (- CENTER-Y Y) color alu) (DRAW-CLIPPED-POINT (+ CENTER-X Y) (- CENTER-Y X) color alu) (DRAW-CLIPPED-POINT (- CENTER-X Y) (+ CENTER-Y X) color alu) (COND ((= Y X) (RETURN)))))))) )) #!C ; From file STREAM.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; STREAM.#" (DEFMETHOD (GRAPHICS-MIXIN :DRAW-FILLED-IN-CIRCLE) (CENTER-X CENTER-Y RADIUS &OPTIONAL (ALU CHAR-ALUF) (color (sheet-foreground-color self))) ;;; note - no texture can be provided since it calls %draw-rectangle, which takes no source array (prepare-color (self color) (PREPARE-SHEET (SELF) (IF (mac-window-p self) (LET ((center-x (+ center-x (sheet-inside-left self))) (center-y (+ center-y (sheet-inside-top self)))) (with-clipping-rectangle (0 0 width height) (send-DrawCircle center-x center-y radius (IF (color-system-p self) color (IF (ZEROP color) w:white w:black)) alu 29 t self))) ;; else... (DO ((X 0) (F 0) ; F is just x^2. Don't use multiplication! (Y RADIUS)) ((> X Y)) (UNLESS (= X Y) (DRAW-RECTANGLE-INSIDE-CLIPPED (+ Y Y 1) 1 (- CENTER-X Y) (+ CENTER-Y X) ALU SELF) (UNLESS (ZEROP X) (DRAW-RECTANGLE-INSIDE-CLIPPED (+ Y Y 1) 1 (- CENTER-X Y) (- CENTER-Y X) ALU SELF))) (SETQ F (+ F X X 1) X (1+ X)) (WHEN (>= F Y) (SETQ F (- F Y Y -1) Y (- Y 1)) (DRAW-RECTANGLE-INSIDE-CLIPPED (+ X X -1) 1 (- CENTER-X X -1) (+ CENTER-Y Y 1) ALU SELF) (DRAW-RECTANGLE-INSIDE-CLIPPED (+ X X -1) 1 (- CENTER-X X -1) (- CENTER-Y Y 1) ALU SELF)))) )) ; end prepare-color ) )) #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-circle) (x-center y-center radius &optional (thickness 1) (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (num-points 29) (texture *default-texture*)) "This method draws a hollow circle. This is a circle which has a thickness." (unless (null color) (IF (mac-window-p self) (prepare-sheet (self) (MULTIPLE-VALUE-BIND (x-radius) (SEND self :transform-point (+ x-center radius) 0) (MULTIPLE-VALUE-BIND (x-center y-center) (send self :transform-point x-center y-center) (MULTIPLE-VALUE-BIND (thickness) (send self :transform-deltas thickness thickness) (send-DrawHollowCircle (ROUND x-center) (ROUND y-center) (ROUND (- x-radius x-center)) (MAX 1 (ROUND thickness)) ;KED 3/14/88, Line weight=0 means thickness=1 color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) num-points self))))) ;; else... (let* ((delta-angle (quotient two-pi num-points)) (x-points (make-array (1+ num-points))) (y-points (make-array (1+ num-points))) (cos-delta (coerce(cos delta-angle) 'short-float)) ;FLOATED these two locals PMH 3/1/88 (sin-delta (coerce(sin delta-angle) 'short-float)) (x radius) (y 0.0)) ;; set the first and last point for the x and y vectors (setf (aref x-points num-points) (setf (aref x-points 0) (+ x-center x))) (setf (aref y-points num-points) (setf (aref y-points 0) (+ y-center y))) (do ((i 1 (1+ i))) ((>= i num-points)) (psetq x (coerce (- (* x cos-delta) (* y sin-delta)) 'short-float) y (coerce (+ (* x sin-delta) (* y cos-delta)) 'short-float)) (setf (aref x-points i) (+ x-center x)) (setf (aref y-points i) (+ y-center y))) (send self :draw-polyline x-points y-points thickness color (1+ num-points) alu t texture))))) )) #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-line) (from-x from-y to-x to-y &optional (thickness 1) (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (draw-end-point t) (texture *default-texture*)) "this method draws a line with a thickness. this is actually a rectangle which is rotated and centered along the line." (unless (null color) (IF (AND (mac-window-p self) (> 2 (SEND self :transform-deltas thickness thickness))) (prepare-sheet (self) (MULTIPLE-VALUE-BIND (from-x from-y) (send self :transform-point from-x from-y) (MULTIPLE-VALUE-BIND (to-x to-y) (send self :transform-point to-x to-y) (send-draw-line (ROUND from-x) (ROUND from-y) (ROUND to-x) (ROUND to-y) (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) draw-end-point self t 1 color) (UNLESS draw-end-point ; Turn off end point. (send-draw-point to-x to-y w:alu-xor w:black self))))) ;; else... (let ((x (make-array 2)) (y (make-array 2))) ;; using initial-contents rather than this more than doubles speed of 140 pixel line !!! KED 3/14/88 (setf (aref x 0) from-x) (setf (aref y 0) from-y) (setf (aref x 1) to-x) (setf (aref y 1) to-y) (send self :draw-polyline x y thickness color 2 alu draw-end-point texture))))) ;; may 05/22/89 ;; 1. fixes for spr 9447 (on MAC) - Now mac side does same as explorer and handles end-point clipping. ;; 2. Trapped single-point case since ucode does not handle it. SPR 9693, :draw-cubic-spline bug. ;; 3. added half-thickness var for code clarity. ;; 4. Backed out incorrect fixes to adjust polyline centering. )) #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-rectangle) (left top r-width r-height &optional (thickness 1) (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (texture *default-texture*) (adjust (send self :adjust)) ;; may 05/16/89 Added ) "this method draws a hollow rectangle whose lines have a thickness. the sides of the rectangle are always orthogonal to the window edges." ;; may 05/22/89 Start patch to trap very small rectangles (multiple-value-bind (pixel-width-x pixel-width-y) (send self :get-scaling-factors) (let ((scaled-rect-width (* r-width pixel-width-x)) (scaled-rect-height (* r-height pixel-width-y))) (cond ;; may 05/22/89 not part of patch ... ((null color)) ;; may 05/22/89 not part of patch ... ((and (<= scaled-rect-width 1) ;; 0 or 1 pixel when scaled (<= scaled-rect-height 1)) (send self :draw-point left top alu color texture)) ;; We need not try to draw a hollow rectangle if we don't have enough room for the interior ((<= (* scaled-rect-width scaled-rect-height) (* pixel-width-x pixel-width-y)) ;; too small to have an interior (send self :draw-filled-rectangle left top r-width r-height color alu t texture)) (t ;; may 05/22/89 ... end patch (IF (mac-window-p self) (prepare-sheet (self) (MULTIPLE-VALUE-BIND (right bottom) (SEND self :transform-point (+ left r-width) (+ top r-height)) (MULTIPLE-VALUE-BIND (left top) (SEND self :transform-point left top) ;;KED 3/14/88, Line weight=0 means thickness=1 (LET ((thickness (MAX 1 (ROUND (send self :transform-deltas thickness thickness))))) (send-DrawHollowRectangle (ROUND left) (ROUND top) (ROUND (- right left)) (ROUND (- bottom top)) thickness color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) self))))) ;;; else... (let* ((right (+ left r-width adjust)) ;; may 05/16/89 (bottom (+ top r-height adjust)) ;; may 05/16/89 (x (make-array 5)) (y (make-array 5))) (setf (aref x 0) left) (setf (aref y 0) top) (setf (aref x 1) right) (setf (aref y 1) top) (setf (aref x 2) right) (setf (aref y 2) bottom) (setf (aref x 3) left) (setf (aref y 3) bottom) (setf (aref x 4) left) (setf (aref y 4) top) (send self :draw-polyline x y thickness color 5 alu t texture )))) )))) )) #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-filled-circle) (x-center y-center radius &optional (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (num-points 29) (draw-edge t) (texture *default-texture*)) "This method draws a solid, filled in circle." (unless (null color) (prepare-sheet (self) (IF (mac-window-p self) (MULTIPLE-VALUE-BIND (x-radius) (SEND self :transform-point (+ x-center radius) 0) (MULTIPLE-VALUE-BIND (x-center y-center) (SEND self :transform-point x-center y-center) (send-DrawCircle (ROUND x-center) (ROUND y-center) (ROUND (- x-radius x-center)) color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) num-points draw-edge self))) ;; else... (let* ((delta-angle (quotient two-pi num-points)) (cos-delta (coerce (cos delta-angle) 'short-float)) (sin-delta (coerce (sin delta-angle) 'short-float)) (dx radius) (dy 0.0) (x-start (+ dx x-center)) (y-start (+ dy y-center)) x2 y2) (do ((i 1 (1+ i)) (x1 x-start x2) (y1 y-start y2)) ((>= i num-points) (draw-clipped-solid-triangle x-center y-center x-start y-start x1 y1 self color alu nil draw-edge t texture)) (psetq dx (- (* dx cos-delta) (* dy sin-delta)) dy (+ (* dx sin-delta) (* dy cos-delta))) (setq x2 (+ x-center dx) y2 (+ y-center dy)) (draw-clipped-solid-triangle x-center y-center x2 y2 x1 y1 self color alu nil draw-edge t texture))) ;; draw the center point (SEND self :draw-filled-rectangle x-center y-center 0 0 color alu t texture) )))) ;; may 05/22/89 Backed out change of patch-4-121 )) #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-filled-rectangle) (left top r-width r-height &optional (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (draw-edge t) (texture *default-texture*) (adjust (send self :adjust)) ;; may 05/17/89 ) "this method draws a solid, filled in rectangle. the sides of the rectangle are always orthogonal to the coordinate axes." ;; may 05/22/89 Start patch to trap single pixel case (multiple-value-bind (pixel-width-x pixel-width-y) (send self :get-scaling-factors) (cond ((null color)) ;; may 05/22/89 not part of patch ... ((and (<= (* r-width pixel-width-x) 1) (<= (* r-height pixel-width-y) 1)) ;; 0 or 1 pixel when scaled (send self :draw-point left top alu color texture)) (t ;; may 05/22/89 ... end patch (prepare-sheet (self) (IF (mac-window-p self) (MULTIPLE-VALUE-BIND (right bottom) (SEND self :transform-point (+ left r-width) (+ top r-height)) (MULTIPLE-VALUE-BIND (left top) (SEND self :transform-point left top) (send-draw-rectangle (ROUND (- right left)) (ROUND (- bottom top)) (ROUND left) (ROUND top) color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) self t))) ;; else... (let ((bottom (+ top r-height adjust)) ;; may 05/22/89 (right (+ left r-width adjust))) ;; may 05/22/89 (draw-clipped-solid-triangle left top left bottom right bottom self color alu () draw-edge draw-edge texture) (draw-clipped-solid-triangle left top right top right bottom self color alu t draw-edge draw-edge texture)) )))))) )) #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-point) (x y &optional (alu char-aluf) (color (IF (color-system-p self) (tv:sheet-foreground-color self) -1 )) (texture *default-texture*)) ;; may 05/09/89 "This method draws a pixel at the window location that corresponds to the world coordinates specified by x and y. The new value is combined with the existing value, based on the alu. In a monochrome window the COLOR is mapped to a gray scale in TEXTURE and TEXTURE defaults to w:b&w-table. In a color window COLOR is used and TEXTURE defaults to w:100%-black. If the TEXTURE array is 1-bit then color expansion is performed which converts a 0 array value to the sheet's background color and converts a 1 array value to the sheet's foreground color. The COLOR arg is ignored when using an 8-bit texture which is just treated as a source of colors." (UNLESS (NULL color) ;; do not error off if nil for color; do like other primitives 12/1/87 KJF (multiple-value-setq (x y) (send self :transform-point x y)) (or (< x (sheet-inside-left)) (>= x (sheet-inside-right)) (< y (sheet-inside-top)) (>= y (sheet-inside-bottom)) (prepare-sheet (self) (IF (mac-window-p self) (send-draw-point x y (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) color self) ;; else... (LET* ((current (AREF screen-array y x)) (color-map (tv:sheet-color-map self)) (background (tv:sheet-background-color self))) ;; may 05/22/89 Start patch to add texture argument ;; COND taken from w:draw-clipped-solid-triangle (cond ((color-sheet-p self) (SETQ color (range-check color)) (UNLESS texture (SETQ texture 100%-black))) ;; ucode si:%draw-shaded-triangle does similiar thing (t (SETQ color (mod color (ARRAY-ACTIVE-LENGTH b&w-table))) ; use MOD not REM to handle negative numbers (UNLESS texture (SETQ texture (AREF b&w-table color))))) (LET ((ary-value (aref texture (mod y (array-dimension texture 0)) (mod x (array-dimension texture 1))))) (if (color-sheet-p self) (if (TYPEP texture '(array bit)) ;; for every 1 in texture - use COLOR. For every 0 in texture use background ;; - this is color expansion (if (zerop ary-value) (setq color background-color) ;; else color is already foreground-color from defaulted arg in arglist ) ;; else is array is 8-bit just use the color in the texture array (SETQ color ary-value)) ;; In monochrome system, color is mapped to a gray-scale using b&w-table (setq color ary-value) )) ;; may 05/22/89 end patch ;; note - new alus are added for color. Since these alus are not understood ;; by the boole function, they must be separated out and handled properly. ;; a little cosmetic fix up here. PMH 4/6/88 (SETF (AREF screen-array y x) (COND ((= alu tv:alu-back) background) ((= alu tv:alu-transp) color) ((= alu tv:alu-add) (MOD (+ color current) 256)) ((= alu tv:alu-sub) (MOD (- current color) 256)) ((= alu tv:alu-max) (MAX color current)) ((= alu tv:alu-min) (MIN color current)) ((= alu tv:alu-avg) (TRUNCATE (+ color current) 2)) ((= alu tv:alu-adds) (MIN (+ color current) (tv:color-map-saturate color-map))) ((= alu tv:alu-subc) (MAX (- current color) (tv:color-map-clamp color-map))) (t (BOOLE alu color current)) )) )))))) ))