;;; -*- Mode:Common-Lisp; Package:X11; Base:10; -*- ;;; For the packrats among us... ;;; This file contains cruft that was deleted from other files ;;; and thrown into here Just In Case it should ever be needed again. ;;; This was the start of a reasonable gcontext resource with all the trimmin's (defresource gcontext (screen depth &optional &key (alu GX-COPY) (plane-mask (LOGNOT 0)) (serial-number 0) (foreground-pixel 0) (background-pixel 1) (line-width 0) (line-style LINE-STYLE-SOLID) (cap-style CAP-STYLE-BUTT) (join-style JOIN-STYLE-MITER) (fill-style FILL-STYLE-SOLID) (fill-rule FILL-RULE-EVEN-ODD) (arc-mode ARC-PIE-SLICE) ;;(font *default-cursor-font*) (tile NIL) (stipple NIL) (pattern-originp (make-point)) (subwindow-mode Subwindow-Mode-Clip-By-Children) (graphics-exposures T) (clip-origin (make-point)) (client-clip-type NIL) (num-in-dash-list 2) (dash (MAKE-ARRAY 2 :element-type 'integer)) (dash-offset 0)) :constructor (make-gcontext) :initializer (setf (gcontext.screen) screen (gcontext.depth) depth (gcontext.alu) alu (gcontext.plane-mask) plane-mask (gcontext.serial-number) serial-number (gcontext.foreground-pixel) foreground-pixel (gcontext.background-pixel) background-pixel (gcontext.line-width) line-width (gcontext.line-style) line-style (gcontext.cap-style) cap-style (gcontext.join-style) join-style (gcontext.fill-style) fill-style (gcontext.fill-rule) fill-rule (gcontext.arc-mode) arc-mode (gcontext.tile) tile (gcontext.stipple) stipple (gcontext.pattern-originp) pattern-originp (gcontext.subwindow-mode) subwindow-mode (gcontext.graphics-exposures) graphics-exposures (gcontext.clip-origin) clip-origin (gcontext.client-clip-type) client-clip-type (gcontext.num-in-dash-list) num-in-dash-list (gcontext.dash) dash (gcontext.dash-offset) dash-offset )) ;;; Old crufty version of cursor initialization. realize-cursor is now ;;; used to do most of the work. ;;; Initialize the CURRENT-CURSOR variable. This can be done any time after the ;;; screens have been set up. This allows a cursor to be "realized" before ;;; there is a client connection. ;;;(DEFUN INITIALIZE-EXPLORER-CURSOR () ;;; (LET ((DEV-PRIVATES (MAKE-ARRAY (SCREEN-INFO.NUM-SCREENS SCREEN-INFO) ;;; :ELEMENT-TYPE 'CR-PRIVATE)) ;;; (CURSOR-WIDTH TV:*MICROCODE-MOUSE-CURSOR-BUFFER-WIDTH*) ;;; (CURSOR-HEIGHT TV:*MICROCODE-MOUSE-CURSOR-BUFFER-HEIGHT*)) ;;; (LOOP WITH NUM-SCREENS = (SCREEN-INFO.NUM-SCREENS SCREEN-INFO) ;;; FOR SCREEN-INDEX FROM 0 BELOW NUM-SCREENS ;;; FOR SCREEN IN (SCREEN-INFO.SCREENS SCREEN-INFO) ;;; FOR ROOT IN (SCREEN-INFO.WINDOWS SCREEN-INFO) ;;; FOR FBD BEING THE ARRAY-ELEMENTS OF FRAME-BUFFER-DESCRIPTORS FROM 0 BELOW NUM-SCREENS ;;; FOR GC = (FRAME-BUFFER-DESCRIPTOR.GCONTEXT FBD) ;;; FOR INV-GC = (FRAME-BUFFER-DESCRIPTOR.INV-GCONTEXT FBD) ;;; FOR DEV-PRIVATE = (MAKE-CR-PRIVATE ;;; :SCREEN-BITS (CREATE-PIXMAP ;;; ROOT ;;; (* CURSOR-WIDTH *CURSOR-SAVED-SCREEN-FACTOR*) ;;; (* CURSOR-HEIGHT *CURSOR-SAVED-SCREEN-FACTOR*) ;;; GC) ;;; :FLUSH-BITS-P NIL ;;; :SOURCE (CREATE-PIXMAP ;;; ROOT ;;; CURSOR-WIDTH ;;; CURSOR-HEIGHT ;;; GC) ;;; :SRC-GC GC ;;; :INV-SOURCE (CREATE-PIXMAP ;;; ROOT ;;; CURSOR-WIDTH ;;; CURSOR-HEIGHT ;;; GC) ;;; :INV-SRC-GC INV-GC ;;; :TEMP (CREATE-PIXMAP ;;; ROOT ;;; (* CURSOR-WIDTH *CURSOR-SAVED-SCREEN-FACTOR*) ;;; (* CURSOR-HEIGHT *CURSOR-SAVED-SCREEN-FACTOR*) ;;; GC) ;;; :FG (GCONTEXT.FOREGROUND-PIXEL GC) ;;; :BG (GCONTEXT.FOREGROUND-PIXEL GC) ;;; :SCREEN-X 0 ;;; :SCREEN-Y 0 ;;; :STATE CR-IN) ;;; DO (PROGN ;;; (SETF (AREF DEV-PRIVATES SCREEN-INDEX) DEV-PRIVATE) ;;; (SETF (WINDOW.CURSOR ROOT) CURRENT-CURSOR))) ;;; (SETF (CURSOR-RECORD.DEV-PRIVATE CURRENT-CURSOR) DEV-PRIVATES) ;;; (SETF (CURSOR-RECORD.XHOT CURRENT-CURSOR) 0) ;;; (SETF (CURSOR-RECORD.YHOT CURRENT-CURSOR) 0) ;;; (SETF (CURSOR-RECORD.WIDTH CURRENT-CURSOR) CURSOR-WIDTH) ;;; (SETF (CURSOR-RECORD.HEIGHT CURRENT-CURSOR) CURSOR-HEIGHT))) ;;; Modified Explorer MOUSE-INPUT function. The real changes are marked via <>. (LET ((INHIBIT-FDEFINE-WARNINGS :JUST-WARN)) (DEFUN W:MOUSE-INPUT (&OPTIONAL (WAIT-FLAG T)) "Wait until mouse moves or a button goes up or down, then report what happened. The values are the delta-x, the delta-y (amounts of mouse motion), buttons-newly-pushed, buttons-newly-raised, and the relevant mouse X and Y (the current position normally, but if any buttons changed, the position then)." ;; Await a change in hardware status from what it was last time (COND (WAIT-FLAG ;; This sleep makes it reasonable for the mouse process to be high priority. ;; It insures that moving the mouse does not lock out lower priority ;; processes for a long time. This constant may want to be tweaked. A ;; value of 1 (1/60 of a second) does not noticably affect mouse response. (PROCESS-SLEEP 1) (PROCESS-WAIT "X Mouse Input" #'(LAMBDA () ;; Added the (AND (NULL X-ENABLED) component <> ;; for X. (AND (NULL X-ENABLED) (OR W:MOUSE-WAKEUP W:MOUSE-RECONSIDER)))))) ;; Clear wakeup flag unless there are buffered mouse button transitions, since we ;; might not read all of them before calling MOUSE-INPUT again. (SETQ W:MOUSE-WAKEUP (NOT (= W:MOUSE-BUTTONS-BUFFER-IN-INDEX W:MOUSE-BUTTONS-BUFFER-OUT-INDEX))) ;; Compute delta-X and delta-Y in screen coordinates (LET ((DELTA-X (- W:MOUSE-X W:MOUSE-LAST-X)) (DELTA-Y (- W:MOUSE-Y W:MOUSE-LAST-Y)) (GLITCH-X NIL) (GLITCH-Y NIL) NEW-BUTTONS CHANGED-BUTTONS) (INCF W:MOUSE-LAST-X DELTA-X) (INCF W:MOUSE-LAST-Y DELTA-Y) ;; Compute change in button status (MULTIPLE-VALUE-SETQ (NEW-BUTTONS W:MOUSE-LAST-BUTTONS-TIME TV:MOUSE-LAST-BUTTONS-X TV:MOUSE-LAST-BUTTONS-Y) (W:MOUSE-BUTTONS)) (SETQ CHANGED-BUTTONS (LOGXOR NEW-BUTTONS W:MOUSE-LAST-BUTTONS) W:MOUSE-LAST-BUTTONS NEW-BUTTONS) ;; Force blinker to stay within mouse-sheet. If the mouse moves during this ;; computation, it will glitch back. So we only SETQ the variables ;; if the mouse position actually needs to be changed, rather than using ;; MAX and MIN which would be more readable. (IF (> 0 W:MOUSE-X) (SETQ GLITCH-X 0)) (IF (<= (W:SHEET-WIDTH W:MOUSE-SHEET) W:MOUSE-X) (SETQ GLITCH-X (1- (W:SHEET-WIDTH W:MOUSE-SHEET)))) (IF (> 0 W:MOUSE-Y) (SETQ GLITCH-Y 0)) (IF (<= (W:SHEET-HEIGHT W:MOUSE-SHEET) W:MOUSE-Y) (SETQ GLITCH-Y (1- (W:SHEET-HEIGHT W:MOUSE-SHEET)))) ;; If mouse blinker needs to be glitched, do so (IF (OR GLITCH-X GLITCH-Y) (WITHOUT-INTERRUPTS (W:%OPEN-MOUSE-CURSOR) (IF GLITCH-X (SETQ W:MOUSE-LAST-X (SETQ W:MOUSE-X GLITCH-X))) (IF GLITCH-Y (SETQ W:MOUSE-LAST-Y (SETQ W:MOUSE-Y GLITCH-Y))) (SETQ W:MOUSE-CURSOR-STATE TV:MOUSE-CURSOR-CLOSED-STATE TV:PREPARED-SHEET NIL))) ;;; (SEND SI:COLD-LOAD-STREAM :STRING-OUT (FORMAT NIL "~16R,~16R " ;;; NEW-BUTTONS CHANGED-BUTTONS)) (VALUES DELTA-X DELTA-Y (LOGAND NEW-BUTTONS CHANGED-BUTTONS) (BOOLE 2 NEW-BUTTONS CHANGED-BUTTONS) ;BOOLE 2 is ANDCA (IF (ZEROP CHANGED-BUTTONS) W:MOUSE-LAST-X TV:MOUSE-LAST-BUTTONS-X) (IF (ZEROP CHANGED-BUTTONS) W:MOUSE-LAST-Y TV:MOUSE-LAST-BUTTONS-Y))))) ;;; Define accessors for the event-masks slot in a window. ;;; Note that the event-masks slot in the window structure contains a list of ;;; OTHER-CLIENT instances. It is assumed that the state is available in the ;;; current lexical environment for these accessors and is in the symbol *STATE*. ;;; This stuff is never used - LGO (DEFMACRO DEFEVENT-MASKS (&REST NAMES) `(PROGN . ,(LOOP FOR NAME IN NAMES FOR DEFNAME = (INTERN (CONCATENATE 'SIMPLE-STRING "WINDOW-" (SYMBOL-NAME NAME))) COLLECT `(DEFSUBST ,DEFNAME (WINDOW) (LOOP FOR CLIENT IN (WINDOW.EVENT-MASKS WINDOW) WHEN (EQ (OTHER-CLIENT.CLIENT CLIENT) *STATE*) DO (RETURN (LOGTEST ,NAME (OTHER-CLIENT.MASK CLIENT))))) COLLECT `(DEFSETF ,DEFNAME (WINDOW) (VALUE) `(DECLARE (SPECIAL *STATE*)) `(LOOP FOR CLIENT IN (WINDOW.EVENT-MASKS ,WINDOW) FOR MASK-STATE = (OTHER-CLIENT.CLIENT CLIENT) FOR MASK-BITS = (OTHER-CLIENT.MASK CLIENT) WHEN (EQ MASK-STATE *STATE*) DO (PROGN (SETF (OTHER-CLIENT.MASK CLIENT) (COND (,VALUE (LOGIOR ,,NAME MASK-BITS)) (T (LOGANDC1 ,,NAME MASK-BITS)))) (RETURN ,VALUE)) FINALLY (PROGN (PUSH (MAKE-OTHER-CLIENT :CLIENT (OR *STATE* (WINDOW.CLIENT ,WINDOW)) :MASK ,,NAME) (WINDOW.EVENT-MASKS ,WINDOW)) (SETF (WINDOW.ALL-EVENT-MASKS ,WINDOW) (LOGIOR (WINDOW.ALL-EVENT-MASKS ,WINDOW) ,,NAME)) ,VALUE)))))) (Defevent-Masks Key-Press-Mask Key-Release-Mask Button-Press-Mask Button-Release-Mask Enter-Window-Mask Leave-Window-Mask Pointer-Motion-Mask Pointer-Motion-Hint-Mask Button1-Motion-Mask Button2-Motion-Mask Button3-Motion-Mask Button4-Motion-Mask Button5-Motion-Mask Button-Motion-Mask Keymap-State-Mask Exposure-Mask Visibility-Change-Mask Structure-Notify-Mask Resize-Redirect-Mask Substructure-Notify-Mask Focus-Change-Mask Property-Change-Mask Colormap-Change-Mask Owner-Grab-Button-Mask) ; Nobody uses this either - LGO (DEFSETF WINDOW-SUBSTRUCTURE-REDIRECT-MASK (WINDOW) (VALUE) `(DECLARE (SPECIAL *STATE*)) `(LOOP FOR CLIENT IN (WINDOW.EVENT-MASKS ,WINDOW) FOR MASK-STATE = (OTHER-CLIENT.CLIENT CLIENT) FOR MASK-BITS = (OTHER-CLIENT.MASK CLIENT) WHEN (EQ MASK-STATE *STATE*) DO (PROGN (SETF (OTHER-CLIENT.MASK CLIENT) (COND (,VALUE (LOGIOR SUBSTRUCTURE-REDIRECT-MASK MASK-BITS)) (T (LOGANDC1 SUBSTRUCTURE-REDIRECT-MASK MASK-BITS)))) ,VALUE) FINALLY (PROGN (PUSH (MAKE-OTHER-CLIENT :CLIENT (OR *STATE* (WINDOW.CLIENT ,WINDOW)) :MASK SUBSTRUCTURE-REDIRECT-MASK) (WINDOW.EVENT-MASKS ,WINDOW)) (SETF (WINDOW.ALL-EVENT-MASKS ,WINDOW) (LOGIOR (WINDOW.ALL-EVENT-MASKS ,WINDOW) SUBSTRUCTURE-REDIRECT-MASK)) SUBSTRUCTURE-REDIRECT-MASK))) ;; Use bignums instead (DEFUN CREATE-DETAIL-MASK () (DECLARE (VALUES DETAIL-MASK)) (MAKE-ARRAY MASKS-PER-DETAIL-MASK :ELEMENT-TYPE 'INTEGER :INITIAL-VALUE -1)) (DEFMACRO DETAIL-BIT-NUMBER-TO-WORD (BIT-NUMBER) `(ASH ,BIT-NUMBER -5)) (DEFMACRO DETAIL-BIT-NUMBER-TO-BIT (BIT-NUMBER) `(ASH 1 (LOGAND ,BIT-NUMBER 31))) (DEFUN DELETE-DETAIL-FROM-MASK (DETAIL-MASK DETAIL) (DECLARE (TYPE (OR NULL DETAIL-MASK) DETAIL-MASK) (TYPE INTEGER DETAIL) (VALUES DETAIL-MASK)) (WHEN (NULL DETAIL-MASK) (SETQ DETAIL-MASK (CREATE-DETAIL-MASK))) (LET ((BIT-NUMBER (DETAIL-BIT-NUMBER-TO-WORD DETAIL))) ;; Clear the bit specified by DETAIL. (SETF (AREF DETAIL-MASK BIT-NUMBER) (LOGXOR (AREF DETAIL-MASK BIT-NUMBER) (DETAIL-BIT-NUMBER-TO-BIT DETAIL)))) ;; We need to return DETAIL-MASK in case a new one was created. DETAIL-MASK) (DEFUN COPY-DETAIL-MASK (ORIGINAL-DETAIL-MASK) (DECLARE (TYPE (OR NULL DETAIL-MASK) ORIGINAL-DETAIL-MASK) (VALUES DETAIL-MASK)) (IF (NULL ORIGINAL-DETAIL-MASK) NIL ;;ELSE (LET ((NEW-MASK (CREATE-DETAIL-MASK))) (DOTIMES (INDEX MASKS-PER-DETAIL-MASK) (SETF (AREF NEW-MASK INDEX) (AREF ORIGINAL-DETAIL-MASK INDEX))) NEW-MASK))) #| (defun CHECK-CURSOR-IN-POINTS (drawable x-origin y-origin line-width coord-mode num-points points offset) (when (and current-cursor (cursor-record.dev-private current-cursor)) (multiple-value-bind (left right top bottom) (cursor-boundries current-cursor) (let* ((minx (+ x-origin (aref points offset))) (miny (+ y-origin (aref points (1+ offset)))) (maxx minx) (maxy miny) (origin-rel-p (eql coord-mode coord-mode-origin))) (cond (origin-rel-p (loop while (plusp (decf num-points)) for i from (+ offset 2) by 2 for x = (+ (aref points i) x-origin) for y = (+ (aref points (1+ i)) y-origin) do (setq minx (min minx x)) (setq miny (min miny y)) (setq maxx (max maxx x)) (setq maxy (max maxy y)))) (:else (setq x-origin minx) (setq y-origin miny) (loop while (plusp (decf num-points)) for i from (+ offset 2) by 2 for x = (+ (aref points i) x-origin) for y = (+ (aref points (1+ i)) y-origin) do (setq minx (min minx x)) (setq miny (min miny y)) (setq maxx (max maxx x)) (setq maxy (max maxy y)) (setq x-origin x) (setq y-origin y)))) |# ;;; Unfinished (DEFUN X-BITBLT-CLIPPED (X-ALU WIDTH HEIGHT SOURCE SOURCE-X SOURCE-Y DEST DEST-X DEST-Y) "Clip the width and height to the source and destination arrays and do a bitblt. Do nothing if any x or y coordinates are out of bounds." (LET ((SRC-WIDTH (ARRAY-WIDTH SOURCE)) (SRC-HEIGHT (ARRAY-HEIGHT SOURCE)) (DST-WIDTH (ARRAY-WIDTH DEST)) (DST-HEIGHT (ARRAY-HEIGHT DEST)) (DOIT T)) (COND ((> SOURCE-X SRC-WIDTH) (setq doit nil)) ((> (+ SOURCE-X WIDTH) SRC-WIDTH) ;; Copying ends after the end of the source array. In this case we will ;; have a tiled effect with BITBLT, which we do not want. (SETQ WIDTH (- SRC-WIDTH SOURCE-X)))) (COND ((> SOURCE-Y SRC-HEIGHT) (SETQ WIDTH NIL)) ((> (+ SOURCE-Y HEIGHT) SRC-HEIGHT) ;; Copying ends after the end of the source array. In this case we will ;; have a tiled effect with BITBLT, which we do not want. (SETQ HEIGHT (- SRC-HEIGHT SOURCE-Y)))) ;; Check bounds of destination (COND ((> BOX-X DST-WIDTH) (SETQ WIDTH NIL)) ((> (+ BOX-X WIDTH) DST-WIDTH) (SETQ WIDTH (- DST-WIDTH BOX-X)))) (COND ((> BOX-Y DST-HEIGHT) (SETQ WIDTH NIL)) ((> (+ BOX-Y HEIGHT) DST-HEIGHT) (SETQ HEIGHT (- DST-HEIGHT BOX-Y)))) (BITBLT (AREF X-ALU-To-Explorer-ALU X-ALU) WIDTH HEIGHT SOURCE SOURCE-X SOURCE-Y DEST DEST-X DEST-Y)) ) (DEFUN PAINT-REGION-BACKGROUND (WINDOW X Y WIDTH HEIGHT) ;; The miexpose.c code in /server/ddx/mi/ restores the background tile, if one exists. ;; If there was a background pixel, we already converted it to ;; a pixmap and store it into the background-pixmap attribute. ;; any background-pixmap specified. (LET ((BACKGROUND-PIXMAP (WINDOW-BACKGROUND WINDOW)) (inside-x (window.absolute-inside-x window)) (inside-y (window.absolute-inside-y window)) (occlusion-stack (window.occlusion-stack window))) (unless (eql BACKGROUND-PIXMAP universal-none) (COND ((NULL OCCLUSION-STACK) ;; Not visible at all. Do nothing. ) ((EQ OCCLUSION-STACK T) ;; Completely visible. Copy background to window. (X-COPY-TO-WINDOW WIDTH HEIGHT BACKGROUND-PIXMAP (MOD (- X inside-x) (PIXMAP.WIDTH BACKGROUND-PIXMAP)) (MOD (- Y inside-y) (PIXMAP.HEIGHT BACKGROUND-PIXMAP)) WINDOW X Y)) (T ;; Partially visible. ;; Iterate through each box of the occlusion stack which ;; intersects with the interior part of the window. (LOOP WITH ABSOLUTE-X = (WINDOW.ABSOLUTE-INSIDE-X WINDOW) WITH ABSOLUTE-Y = (WINDOW.ABSOLUTE-INSIDE-Y WINDOW) FOR INNER-BOX IN (SET-INTERSECT-BOXES OCCLUSION-STACK (MAKE-WINDOW-BOX-INTERIOR WINDOW)) FOR BOX-X = (- (BOX.LEFT INNER-BOX) ABSOLUTE-X) FOR BOX-Y = (- (BOX.TOP INNER-BOX) ABSOLUTE-Y) DO (X-COPY-TO-WINDOW (BOX.WIDTH INNER-BOX) (BOX.HEIGHT INNER-BOX) BACKGROUND-PIXMAP (MOD (- BOX-X inside-x) (PIXMAP.WIDTH BACKGROUND-PIXMAP)) (MOD (- BOX-Y inside-y) (PIXMAP.HEIGHT BACKGROUND-PIXMAP)) WINDOW BOX-X BOX-Y))))))) ;;----------------------------------------------------------------------------- ;;; Bitmap stuff... (DEFUN PIXMAP-DEPTH (PIXMAP) "Return the number of bits per element of a pixmap." (LET ((ELEMENT-TYPE (ARRAY-ELEMENT-TYPE PIXMAP))) (IF (EQ ELEMENT-TYPE 'BIT) 1 ;;ELSE (WHEN (NOT (EQ (CAR ELEMENT-TYPE) 'MOD)) (ERROR "Trying to determine the depth of a pixmap which is of an unknown type.")) (CADR (ASSOC (CADR ELEMENT-TYPE) `((,(EXPT 2 1) 1) (,(EXPT 2 2) 2) (,(EXPT 2 4) 4) (,(EXPT 2 8) 8) (,(EXPT 2 16) 16) (,(EXPT 2 32) 32)) :TEST #'EQUAL))))) ;;; This function is intended to be a way to set all elements of a bit array to 0. (si:make-obsolete CLEAR-TEMP-ARRAY find-a-better-way) ;;; If you think you want this, see LaMott first. (DEFUN CLEAR-TEMP-ARRAY (ARRAY) (LET ((WIDTH (ARRAY-DIMENSION ARRAY 1)) (HEIGHT (ARRAY-DIMENSION ARRAY 0))) (BITBLT W:ALU-XOR WIDTH HEIGHT ARRAY 0 0 ARRAY 0 0))) ;;----------------------------------------------------------------------------- (DEFVAR X-BITMAP-MOUSE-PATHNAME "SYS:WINDOW;GODZILLA-MOUSE.BITMAP") ;;(DEFVAR X-BITMAP-MOUSE-PATHNAME "KDB:TEMP-JAWS;BOB.BITMAP") ;;"KDB:TEMP-JAWS;X-CURSOR.BITMAP") (DEFVAR X-BITMAP-MOUSE-MAX-WIDTH 180) (DEFVAR X-BITMAP-MOUSE-MAX-HEIGHT 180) (DEFUN LOAD-X-BITMAP-MOUSE () "Load the bitmap mouse." (MULTIPLE-VALUE-BIND (ARRAY WIDTH HEIGHT) (COND ((PROBE-FILE X-BITMAP-MOUSE-PATHNAME) (TV:READ-BIT-ARRAY-FILE X-BITMAP-MOUSE-PATHNAME)) (T (VALUES 0 0))) (SETQ X-BITMAP-MOUSE-MAX-WIDTH WIDTH X-BITMAP-MOUSE-MAX-HEIGHT HEIGHT) ARRAY)) (DEFVAR X-BITMAP-MOUSE (LOAD-X-BITMAP-MOUSE) "Bitmap for the X Bitmap mouse.") (DEFUN DRAW-X-MOUSE-CURSOR () "Draw a bitmap as a mouse cursor." ;; When we were not successful loading the bitmap mouse then use the default `big' mouse. (LET* ((MIN-X 0) (MIN-Y 0) (WIDTH-MAX X-BITMAP-MOUSE-MAX-WIDTH ) (HEIGHT-MAX X-BITMAP-MOUSE-MAX-HEIGHT) (HALF-WIDTH (TRUNCATE WIDTH-MAX 2)) (HALF-HEIGHT (TRUNCATE HEIGHT-MAX 2)) (MAX-X (1- (W:SHEET-INSIDE-WIDTH W:MOUSE-SHEET))) (MAX-Y (1- (W:SHEET-INSIDE-HEIGHT W:MOUSE-SHEET))) ;; Center the image on the current mouse position. (X (MAX MIN-X (- W:MOUSE-X HALF-WIDTH))) (Y (MAX MIN-Y (- W:MOUSE-Y HALF-HEIGHT))) ;; Make sure that the image stays within the mouse-sheet. (WIDTH (MIN WIDTH-MAX (- MAX-X X))) (HEIGHT (MIN HEIGHT-MAX (- MAX-Y Y)))) (TV:SHEET-IS-PREPARED (W:MOUSE-SHEET) (WITHOUT-INTERRUPTS (BITBLT W:ALU-XOR WIDTH HEIGHT X-BITMAP-MOUSE 0 0 (W:SHEET-SCREEN-ARRAY W:MOUSE-SHEET) X Y) (DOTIMES (I (* 2 TV:MOUSE-FAST-MOTION-BITMAP-TIME))) (BITBLT W:ALU-XOR WIDTH HEIGHT X-BITMAP-MOUSE 0 0 (W:SHEET-SCREEN-ARRAY W:MOUSE-SHEET) X Y))))) ;;----------------------------------------------------------------------------- ;; This is the COLOR version, using bitblt-under-mask (and very s l o w) (DEFUN DRAWING-EPILOGUE (TEMPORARY-BITMAP DRAWABLE DRAWABLE-BOUNDARIES GCONTEXT DRAWABLE-HAS-CHILDREN DRAWN-ON-TEMPORARY) "Finish up a complex drawing operation by drawing from a temporary array to the drawable." (LET* ((WINDOW-P (TYPEP DRAWABLE 'WINDOW)) (BACKING-STORE (IF (AND WINDOW-P (WINDOW.BACKING-STORE DRAWABLE)) (PIXMAP.ARRAY (WINDOW.BACKING-STORE DRAWABLE)) ;;ELSE NIL)) (DRAWABLE-WIDTH (BOX.WIDTH DRAWABLE-BOUNDARIES)) (DRAWABLE-HEIGHT (BOX.HEIGHT DRAWABLE-BOUNDARIES)) (DESTINATION (DEVICE-PRIVATE-ARRAY DRAWABLE)) (DESTINATION-X (IF WINDOW-P (WINDOW.ABSOLUTE-INSIDE-X DRAWABLE) 0)) (DESTINATION-Y (IF WINDOW-P (WINDOW.ABSOLUTE-INSIDE-Y DRAWABLE) 0)) (TEMPORARY-BITMAP-ARRAY (IF (TYPEP TEMPORARY-BITMAP 'PIXMAP) (PIXMAP.ARRAY TEMPORARY-BITMAP) ;;ELSE We aren't going to use this. NIL)) (FOREGROUND-TILE (GCONTEXT.FOREGROUND-TILE GCONTEXT))) (IF (NOT DRAWN-ON-TEMPORARY) (WHEN BACKING-STORE (X-BITBLT (GCONTEXT.ALU GCONTEXT) DRAWABLE-WIDTH DRAWABLE-HEIGHT DESTINATION DESTINATION-X DESTINATION-Y BACKING-STORE 0 0)) ;;ELSE (PROGN ;; We did all drawing to a temporary array because the real drawing operation ;; was too complex. We'll need to finish up by drawing from the temporary ;; array through the stipple/tile/clip-mask onto the drawable. (WHEN (AND (TYPEP DRAWABLE 'WINDOW) (NOT (WINDOW.MAPPED-P DRAWABLE)) (WINDOW.BACKING-STORE DRAWABLE)) ;; This window isn't mapped but it has a backing store. What really is supposed ;; to happen is that the backing store gets updated and we leave the window alone. ;; Note that this differs from the case of a mapped window with a backing store. ;; In that case we need to both update the part of the window that is visible in ;; addition to updating the backing store. (SETQ DRAWABLE (WINDOW.BACKING-STORE DRAWABLE)) (SETQ WINDOW-P NIL BACKING-STORE NIL DESTINATION-X 0 DESTINATION-Y 0)) (LET* ((FILL-STYLE (GCONTEXT.FILL-STYLE GCONTEXT)) (OCCLUSION-STACK (IF WINDOW-P (WINDOW.OCCLUSION-STACK DRAWABLE) ;;ELSE ;; T means that nothing is occluded. T)) (TILE (PIXMAP.ARRAY (GCONTEXT.TILE GCONTEXT))) (STIPPLE (GCONTEXT.STIPPLE GCONTEXT)) (DRAWABLE-BORDER-WIDTH (IF (TYPEP DRAWABLE 'WINDOW) (WINDOW.BWIDTH DRAWABLE) 0))) (LABELS ((COPY-TO-BACKING-STORE () (WHEN BACKING-STORE (COND ((TILED-P) (PERFORM-TILING BACKING-STORE 0 0)) ((OPAQUE-STIPPLED-P) (PERFORM-OPAQUE-STIPPLING BACKING-STORE 0 0)) (T (BITBLT-UNDER-MASK (GCONTEXT.ALU GCONTEXT) DRAWABLE-WIDTH DRAWABLE-HEIGHT TEMPORARY-BITMAP-ARRAY 0 0 FOREGROUND-TILE 0 0 BACKING-STORE 0 0))))) (SIMPLE-DESTINATION-RENDER () ;; If foreground-tile is all ones, this is essentially a bitblt using alu-ior ;; If foreground-tile is all zeros, this is essentially a bitblt using alu-andca (BITBLT-UNDER-MASK (GCONTEXT.ALU GCONTEXT) DRAWABLE-WIDTH DRAWABLE-HEIGHT TEMPORARY-BITMAP-ARRAY 0 0 FOREGROUND-TILE 0 0 DESTINATION DESTINATION-X DESTINATION-Y OCCLUSION-STACK)) (STIPPLED-P () (AND (= FILL-STYLE FILL-STYLE-STIPPLED) (GCONTEXT.STIPPLE GCONTEXT))) (TILED-P () (= FILL-STYLE FILL-STYLE-TILED)) (OPAQUE-STIPPLED-P () (= FILL-STYLE FILL-STYLE-OPAQUE-STIPPLED)) (PERFORM-TILING (DESTINATION DESTINATION-X DESTINATION-Y) ;;; (SERVER-TRACE "~%performing tiling at (~d,~d)" ;;; destination-x destination-y) (IF (AND (= (ARRAY-TOTAL-SIZE TILE) 1) ; Only 1 pixel. (= (AREF TILE 0 0) (GCONTEXT.FOREGROUND-PIXEL GCONTEXT))) ;; We really don't have much of a tile, since this is ;; just like not having one at all. (SIMPLE-DESTINATION-RENDER) ;;ELSE (PROGN ;; The tile is the source of pixels for the image. What we need ;; to do is to clear out the pixels we are going to draw and then ;; draw our image using the tile. In this way we will draw both ;; the zero and one pixels of our monochrome tile. (BITBLT-UNDER-MASK GX-CLEAR DRAWABLE-WIDTH DRAWABLE-HEIGHT TEMPORARY-BITMAP-ARRAY 0 0 FOREGROUND-TILE (POINT.X (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) (POINT.Y (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) DESTINATION DESTINATION-X DESTINATION-Y OCCLUSION-STACK) (BITBLT-UNDER-MASK (GCONTEXT.ALU GCONTEXT) DRAWABLE-WIDTH DRAWABLE-HEIGHT TEMPORARY-BITMAP-ARRAY 0 0 TILE (POINT.X (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) (POINT.Y (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) DESTINATION DESTINATION-X DESTINATION-Y OCCLUSION-STACK)))) (PERFORM-OPAQUE-STIPPLING (DESTINATION DESTINATION-X DESTINATION-Y) ;; What this means is to create a temporary tile ;; which is the size of the stipple, and to place ;; the foreground color in this temporary tile ;; everywhere the stipple has a one, and put the ;; background color where the stipple has a zero. (IF (OR (NULL (GCONTEXT.STIPPLE GCONTEXT)) (AND (= (ARRAY-TOTAL-SIZE STIPPLE) 1) ; Only 1 bit (= (AREF STIPPLE 0 0) 1))) ;; We really don't have much of a tile here either, ;; since there is no stipple pattern, or we have a ;; stipple with only one bit and it is a 1. (SIMPLE-DESTINATION-RENDER) ;;ELSE ;; What we need to do is to create a temporary tile ;; with pixels set as was described above. (LET* ((STIPPLE (GCONTEXT.STIPPLE GCONTEXT)) (STIPPLE-WIDTH (PIXMAP.WIDTH STIPPLE)) (STIPPLE-HEIGHT (PIXMAP.HEIGHT STIPPLE)) ;; Create the tile and initialize it with ;; the background color. (TEMP-TILE (PIXMAP.ARRAY (CREATE-PIXMAP DRAWABLE STIPPLE-WIDTH STIPPLE-HEIGHT GCONTEXT ; Depth (GCONTEXT.BACKGROUND-PIXEL GCONTEXT))))) ;; Copy foreground pixels to the temp-tile ;; where the stipple says to do so. (BITBLT-UNDER-MASK GX-COPY STIPPLE-WIDTH STIPPLE-HEIGHT (PIXMAP.ARRAY STIPPLE) 0 0 FOREGROUND-TILE 0 0 TEMP-TILE 0 0) ;; Here is where the real work is done. Copy the ;; pixels from the temp-tile to the destination. ;; The tile is the source of pixels for the image. What we need ;; to do is to clear out the pixels we are going to draw and then ;; draw our image using the tile. In this way we will draw both ;; the zero and one pixels of our monochrome tile. (BITBLT-UNDER-MASK GX-CLEAR DRAWABLE-WIDTH DRAWABLE-HEIGHT TEMPORARY-BITMAP-ARRAY 0 0 FOREGROUND-TILE (POINT.X (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) (POINT.Y (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) DESTINATION DESTINATION-X DESTINATION-Y OCCLUSION-STACK) (BITBLT-UNDER-MASK (GCONTEXT.ALU GCONTEXT) DRAWABLE-WIDTH DRAWABLE-HEIGHT TEMPORARY-BITMAP-ARRAY 0 0 TEMP-TILE (POINT.X (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) (POINT.Y (GCONTEXT.PATTERN-ORIGINP GCONTEXT)) DESTINATION DESTINATION-X DESTINATION-Y OCCLUSION-STACK))))) ;; Function body starts here. ;;; (SERVER-TRACE "~%Entering drawing-epilogue, ~ ;;; (LENGTH (GCONTEXT.RECTANGLE-LIST GCONTEXT))=~d, ~ ;;; clip-mask=~a, subwindow mode=~d, DRAWABLE-HAS-CHILDREN=~a" ;;; (LENGTH (GCONTEXT.RECTANGLE-LIST GCONTEXT)) ;;; (GCONTEXT.CLIP-MASK GCONTEXT) ;;; (GCONTEXT.SUBWINDOW-MODE GCONTEXT) ;;; DRAWABLE-HAS-CHILDREN) ;;; (SERVER-TRACE "~%Drawable boundaries=~a" ;;; drawable-boundaries) ;;; (SEND SI:COLD-LOAD-STREAM :TYI) (IF (AND (= (LENGTH (GCONTEXT.RECTANGLE-LIST GCONTEXT)) 1) ;; No clipping mask either. (NULL (GCONTEXT.CLIP-MASK GCONTEXT))) (IF (AND (= (GCONTEXT.SUBWINDOW-MODE GCONTEXT) SUBWINDOW-MODE-CLIP-BY-CHILDREN) DRAWABLE-HAS-CHILDREN) (IF (AND (TYPEP DRAWABLE 'WINDOW) (FILL-STYLE-SOLID-P GCONTEXT) (or (EQ OCCLUSION-STACK T) ;; only one visible rectangle (null (cdr occlusion-stack)))) ;; We are done. The window had a subwindow, which was probably a label, ;; and it completely covered one of the window's edges. This made ;; calculating the simple clipping rectangle possible, so we clipped to ;; the interior part of the window, excluding the subwindow. This case ;; is handled because it is expected to occur frequently. NIL ;;ELSE (LET ((CLIP-PIXMAP (get-clip-pixmap drawable drawable-width drawable-height))) ;; Next we need to check for a stippl