;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Written 04/18/89 12:31:22 by MARKY, ;;; Reason: Changes to bitblt-blinker and magnifying-blinker to correct ;;; bug when blinker goes into right margin. ;;; while running on MX5 from band NB22 ;;; With SYSTEM 5.29, GC 5.3, VIRTUAL-MEMORY 5.5, MICRONET 5.5, MICRONET-COMM 5.13, ;;; DISK-IO 5.9, BASIC-PATHNAME 5.2, MAC-PATHNAME 5.0, NETWORK-SUPPORT-COLD 5.1, ;;; BASIC-NAMESPACE 5.6, BASIC-FILE 5.3, RPC 5.4, NFS 5.10, EH 5.3, MAKE-SYSTEM 5.2, ;;; MEMORY-AUX 5.1, MACTOOLBOX 1.36, COMPILER 5.1, TV 5.28, NVRAM 5.1, UCL 5.0, INPUT-EDITOR 5.0, ;;; METER 5.0, ZWEI 5.14, DEBUG-TOOLS 5.1, WINDOW-MX 5.28, PRINTER 5.11, MAC-PRINTER-TYPES 5.4, ;;; NETWORK-PATHNAME 5.0, NETWORK-NAMESPACE 5.0, DATALINK 5.7, CHAOSNET 5.6, NETWORK-SUPPORT 5.0, ;;; NETWORK-SERVICE 5.0, DATALINK-DISPLAYS 5.0, NAMESPACE-EDITOR 5.1, IP 3.33, NFS-SERVER 5.3, ;;; PRINTER-TYPES 5.2, IMAGEN 5.1, MAIL-DAEMON 5.1, MAIL-READER 5.3, TELNET 5.1, ;;; VT100 5.0, STREAMER-TAPE 5.6, DECNET 1.45, VISIDOC 5.4, PROFILE 5.1, DISK-LABEL 5.1, ;;; MX-SERIAL 1.1, microcode 128, Band Name: microExplorer Network (11/22) ;;; SPR 9266,9271. By may, code-read lg. ;;; Changed a lot in order to allow MX and color compatibility. ;;; See comments in source code, too. ;;; This patch is the same as 4.124 plus 4.127 #!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.#" (DEFSUBST before-blinker-blink () (SETQ PREPARED-SHEET NIL) ;Blinking any blinker makes us forget (SETQ TIME-UNTIL-BLINK HALF-PERIOD) ;Schedule the next blink (wink??) (WHEN sib-is-csib (IF (color-system-p sheet) ; load up the registers in preparation for blinking in color (PROGN ;; ** NOTE POSSIBLE IMPROVEMENT ** - Use ALU-XOR and *default-blinker-color*. - GRH 8/12/88 ;; code here could then be (send ... :set-foreground-color-register ;; (logxor *default-blinker-color* ;; (send sheet :background-color))) (send (aref *blocks* 0) :set-foreground-color-register blinker-offset) ; add this amount to make a mouse (send (aref *blocks* 0) :set-background-color-register 0)) ; we don't want to affect the background (PROGN (send (aref *blocks* 0) :set-foreground-color-register *current-foreground*) ;; set for B&W operation (send (aref *blocks* 0) :set-background-color-register *current-background*))) ;; set plane mask for the plane with blinkers on it. ;; LOGAND'ing prevents overridding the screens' plane-mask. 04/10/88 KJF. (SEND sheet :write-plane-mask (LOGAND (sheet-plane-mask (get-screen sheet)) (sheet-plane-mask sheet)))) (AND FOLLOW-P (SETQ X-POS (SHEET-CURSOR-X SHEET) Y-POS (SHEET-CURSOR-Y SHEET)))) ;; may 02/23/89 (DEFMETHOD (BLINKER :BEFORE :BLINK) () (before-blinker-blink)) ;; may 02/23/89 Rewrote to use sheet not screen for ;; width and simplified. SPR 9266-9271 (DEFMETHOD (BITBLT-BLINKER :BLINK) () (LET* ((SCREEN-ARRAY (SHEET-SCREEN-ARRAY SHEET)) (SWIDTH (tv:sheet-inside-right sheet)) (SHEIGHT (tv:sheet-inside-bottom sheet))) (BITBLT (MOUSE-ALU PHASE) width height ARRAY 0 0 SCREEN-ARRAY (MIN x-pos (- swidth width)) (MIN y-pos (- sheight height))))) (DEFFLAVOR MAGNIFYING-BLINKER ((MAGNIFICATION 3.) (local-copy nil)) ;; may 02/22/89 added (BITBLT-BLINKER) (:SETTABLE-INSTANCE-VARIABLES)) (DEFSUBST check-local-copy-size (nwidth nheight) "Internal function for MAGNIFYING-BLINKER." (WHEN (OR (NULL local-copy) (> nwidth (ARRAY-DIMENSION local-copy 1)) (> nheight (ARRAY-DIMENSION local-copy 0))) (SETF local-copy (w:make-sheet-bit-array sheet nwidth nheight)))) (DEFMETHOD (MAGNIFYING-BLINKER :AFTER :INIT) (IGNORE) (UNLESS (AND (ZEROP (REM HEIGHT MAGNIFICATION)) (ZEROP (REM WIDTH MAGNIFICATION))) (FERROR NIL "Height (~D) and width (~D) are not multiples of magnification (~D)." HEIGHT WIDTH MAGNIFICATION)) (check-local-copy-size height width)) ;; may 02/23/89 ;; may 02/22/89 NEW (DEFMETHOD (MAGNIFYING-BLINKER :after :SET-SIZE) (NWIDTH NHEIGHT) ;; Make sure local-copy array is big enough, too (check-local-copy-size nheight nwidth)) ;; may 02/23/89 NEW ;; TURN off mouse blinker so that it does not get magnified and ;; make the magnified image harder to read. (DEFWRAPPER (MAGNIFYING-BLINKER :BLINK) (IGNORE . BODY) `(LET ((INHIBIT-SCHEDULING-FLAG T)) (open-blinker tv:mouse-blinker) . ,BODY)) ;; may 02/23/89 Rewrite. ;; Sometimes ... (moving this blinker in the tv:inspect-window-with-typeout while ;; doing a ctr-r refresh in inspector) ... ;; rectangle turds are left on the screen. This is because the (BLINKER :BEFORE :BLINK) method has not ;; yet had a chance to load the fg/bg reg's and set the plane mask. ;; For this reason we must include the guts of (BLINKER :BEFORE :BLINK) in this method ! ;; may 04/18/89 ****** changed calc of from-x & from-y to use -x-pos- & -y-pos- ;; since using x-pos & y-pos caused cold load stream bitblt error *ONLY* when ;; ofsets where non-zero. Also removed unnecessary fill of local-copy. (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)) (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))))) ))