;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Changes: ;;; ;;; 10-Jun-94 Mickish Don't set :very-first-exposure slot for Mac ;;; 05-May-94 Mickish Raise-window and lower-window now signal an error if ;;; their arugment is not a real window ;;; 14-Apr-94 Mickish Special Mac stuff in Configure-Notify ;;; 15-Jan-94 Mickish Called gem:color-to-index in Create-X-Drawable ;;; 9-Jan-94 Mickish New function Install-Bitmap-Images now called from ;;; Initialize-Display ;;; 15-Dec-93 Mickish Commented out body of Set-Window-Cursor for Mac ;;; 27-Oct-93 Mickish Only set :title of window if appropriate ;;; 06-Sep-93 Clive Tong Use special Map-Window-And-Wait for LispWorks ;;; 03-Aug-93 Mickish Destroyed drawables that have title bars when reparenting ;;; 28-Jul-93 Mickish Removed title bars when reparenting top-level windows ;;; 20-May-93 Mickish Fixed left-border-width for DECwindows ;;; 17-May-93 koz On an exposure with count>0, just merge the exposed ;;; bbox into the window's win-update-info-exposed-bbox ;;; (so we get only one update call per exposure). ;;; 22-Apr-93 Mickish Added With-Cursor and With-HourGlass-Cursor ;;; 19-Apr-93 Mickish Added font-from-file and :CURSOR to Set-Window-Cursor ;;; 24-Mar-93 koz Better window reparenting: rewrote fix-window-properties ;;; for slot :parent (also, create-x-drawable now sets ;;; the :old-parent slot of the window) ;;; 18-Jan-93 Mickish Added Change-Cursors and Restore-Cursors ;;; 16-Jan-93 Mickish In Fix-Window-Properties, compensate for border widths ;;; when setting :left and :top of windows; in delete-notify, ;;; destroy orphaned drawables when appropriate ;;; 4-Jan-93 Mickish Added checks for NIL drawables to event functions (like ;;; opal::Exposure) since opal:clean-up destroys drawables. ;;; 21-Dec-92 Mickish Added display-force-output calls to raise-window and ;;; lower-window; rewrote Set-Window-Cursor to reuse old ;;; xlib:cursor objects. ;;; 10-Dec-92 Mickish *drawable-to-window-mapping* ---> *garnet-windows* ;;; 28-Oct-92 hopkins In Initialize-Window-Border-Widths, changed border-width ;;; computations for TVTWM ;;; 22-Oct-92 koz Added #'zoom-window and #'fullzoom-window ;;; 6-Oct-92 koz Changed #'update-slot-invalidated to a g-value ;;; of opal:WINDOW :invalidate-demon ;;; 11-Sep-92 Duchier Changed "(4 6)" clauses in Configure-Notify and ;;; Initialize-Window-Border-Widths for tvtwm ;;; 24-Jun-92 Pervin Add #-clx-cl-error test before xlib:drawable-root. ;;; 29-May-92 Pervin Lispworks switch ;;; 27-May-92 Pervin Added :save-under slot to windows. ;;; 18-May-92 Pervin In configure-notify, check that windows are not destroyed. ;;; 13-May-92 Pervin Only do map-window-and-wait if xlib:window-map-state ;;; of window is :unmapped. Do map-window-and-wait in ;;; Allegro version 4 after all. ;;; 4-May-92 Almond Allegro-v4.1 switches ;;; 29-Apr-92 Pervin Reduced :timeout in map-window-and-wait to 5 sec. ;;; Only do wait in map-window-and-wait in Lucid and Allegro <4.0. ;;; 21-Apr-92 Pervin Using new function main-event-loop-process-running-p ;;; 20-Apr-92 Pervin Fixed minor bug in raise-window. ;;; 16-Apr-92 Pervin At end of Configure-notify, do not update windows that have ;;; never been updated before. (see change of 6-Sep-90). ;;; Also, need special case for if xlib:query-tree doesn't work. ;;; 14-Apr-92 Pervin Uncommented out process code. Got multiprocess to work on HP. ;;; 8-Apr-92 Davis In fix-window-properties, when changed slot is :aggregate, ;;; check that old-agg is not destroyed. ;;; 8-Apr-92 Pervin On a black-and-white screen, draw background-color white ;;; except when background-color is actually opal:black. ;;; 31-Mar-92 Pervin New :draw-on-children slot of window. ;;; 31-Mar-92 Szekely New :icon-bitmap slot of window holds pixmap of icon. ;;; 30-Mar-92 Pervin Temporarily commenting out process code. ;;; 25-Mar-92 Pervin Make default-event-handler be only defined in i-windows.lisp. ;;; Use switch #+clx-cl-error to check for query-tree bug. ;;; 20-Mar-92 Pervin Use launch-main-event-loop-process. ;;; 19-Mar-92 Mickish Bound a-window-update-info in :initialize method for ;;; windows to eliminate CMUCL compiler warnings ;;; 18-Mar-92 Pervin Map-window-and-wait no longer needed now that we ;;; have main event loop process. ;;; 11-Mar-92 Pervin New width and height fields of win-update-info. ;;; 5-Mar-92 Pervin If a window is iconified before it is first updated, ;;; its initial state should be :iconic. ;;; Also, should use xlib:withdraw-window, not xlib:unmap-window ;;; 27-Feb-92 Pervin Added deiconify-window. ;;; 19-Feb-92 Pervin Implemented double-clip-mask as list of length 8. ;;; 11-Feb-92 Pervin Vastly simplified expand-buffer to just create new buffer ;;; 03-Jan-92 Mickish Changed to call with-demon-disabled. ;;; 31-Jan-92 Pervin Eliminated *display-name-to-display-mapping*. ;;; Rewrote initialize-display to take no arguments, ;;; and always set display-info-display to be default. ;;; This was needed for conversion to CMUCL. ;;; 23-Jan-92 Pervin Call *exit-main-event-loop-function* instead of throwing ;;; exception. ;;; 21-Jan-91 Pervin Remove subwindow from parent when it is destroyed. ;;; 9-Jan-91 Pervin Map-window-and-wait routine. ;;; 16-Dec-91 Pervin Removed the section of Exposure that merged several ;;; exposure events. ;;; 9-Dec-91 Pervin opal-gc has new stored-clip-mask field ;;; 5-Dec-91 Pervin In Exposure, do not re-update window that has been ;;; exposed for the very first time. ;;; 26-Nov-91 Pervin changed clear-buffer to correctly handle double-buffered ;;; windows with background color. ;;; 25-Nov-91 koz changed fix-properties method to fix-window-properties ;;; function and altered # of args to it (it's only called ;;; from within update-windows, and this is more efficient) ;;; 18-Nov-91 Pervin Added :background-color to windows. ;;; 5-Nov-91 Irwin You may now destroy a window using f.delete or f.kill. ;;; Also, a window can have :min-width, :min-height, ;;; :max-width, and :max-height. ;;; 24-Oct-91 Pervin Exit main-event-loop automatically if no windows visible ;;; Also :visible is set to :iconified if you iconify by hand ;;; 9-Oct-91 Szekely Fixed OpenWindows bug in Configure-notify. ;;; 25-Jun-91 Meltsner Fixed :lineage of DECWindows. ;;; 7-Jun-91 Pervin Added kr:with-demons-disabled inside map-notify and ;;; unmap-notify. ;;; 30-May-91 Pervin Fixed bug so window will not de-iconify if you ;;; call inter:main-event-loop after calling iconify-window. ;;; 4-Apr-91 Pervin New slot :omit-title-bar-p for windows. ;;; 18-Mar-91 Pervin Xlib:query-tree seems to have been fixed in ;;; Allegro Version 4.0. ;;; 21-Feb-91 Pervin New exported routine iconify-window. ;;; 31-Jan-91 Pervin In fix-properties, when a window is made visible, ;;; call xlib:map-window last. ;;; 12-Nov-90 Pervin Made first argument to convert-coordinates optional. ;;; 9-Nov-90 Pervin Made second argument to convert-coordinates optional. ;;; 31-Oct-90 Pervin Finally added convert-coordinates, which I'd ;;; forgotten before. ;;; 29-Oct-90 Pervin Fixed bug found by Brad VanderZanden involving ;;; expanding a double-buffered window (caused by ;;; misprint in Configure-Notify). ;;; 25-Oct-90 Pervin New exported commands opal:raise-window and ;;; opal:lower-window which move window to front or ;;; back of screen. ;;; 22-Oct-90 Pervin Changed #+pmax to #+allegro since I found that ;;; xlib:query-tree no longer works on the Sun Allegro ;;; at CMU either. This is a TEMPORARY change. In time ;;; I hope whoever is responsible can get xlib:query-tree ;;; working. ;;; 10-Sep-90 Meltsner Fixed bug in initialize-window-border-widths of ;;; DECWindow users. w5 --> p5 ;;; 6-Sep-90 Pervin Added an update-all at the end of Configure-Notify. ;;; 24-Aug-90 Pervin You can now reset the :title and :icon-title ;;; of a window. ;;; 15-Aug-90 Pervin Removed :display branch of case statement ;;; in fix-properties. ;;; 13-Aug-90 Pervin Added code to handle DECWindows window manager. ;;; 10-Aug-90 Pervin It turns out that I did need that event-case at ;;; the end of create-x-drawable after all (see 2-Aug-90). ;;; 9-Aug-90 Pervin Added temporary #+pmax stuff because currently ;;; xlib:query-tree does not work on the Pmax. ;;; 3-Aug-90 Pervin In Configure-Notify, check is window has parent. ;;; 2-Aug-90 Pervin Reparent-notify must reset :lineage slot. ;;; Also, didn't need event-case at end of create-x-drawable. ;;; 1-Aug-90 Pervin Made it so that the :width and :height slots of ;;; windows are based on the inside, rather than the ;;; outside of the window. ;;; 30-Jul-90 Pervin Big changes in initialize-window-border-widths ;;; and Configure-Notify to handle MWM window manager. ;;; Got rid of :just-did-configure slot, but added ;;; new :lineage slot. ;;; 18-Jul-90 Pervin Moved the call to initialize-window-border-widths ;;; yet again -- this time, to inside Configure-Notify. ;;; Also, expand-buffer uses :width, :height slots of ;;; window being expanded. ;;; 13-Jul-90 Pervin New :destroy-me method for windows. ;;; I had to remove the optional erase argument. ;;; 5-Jul-90 Pervin In Exposure, don't need special case for ;;; double-buffered window. ;;; 2-Jul-90 Pervin If an expose event occurs, just refresh the parts ;;; of the window that were exposed. ;;; 26-Jun-90 Pervin Extended :just-did-configure test to :width and ;;; :height slots, as well as :top and :left. ;;; 18-Jun-90 Pervin Variable *clear* for erasing buffers. ;;; 5-Jun-90 Pervin Implemented double-buffering. ;;; 4-Jun-90 Myers Added :just-did-configure slot to windows ;;; in order to get rid of *twm-bug* ;;; 25-May-90 Pervin Call initialize-window-border-widths only at the ;;; very end of create-x-drawable. ;;; 8-May-90 Sannella/Pervin ;;; The way of specifying a user-positioned window ;;; has changed. Now we use the :user-specified-position-p ;;; argument to xlib:set-standard-properties. ;;; 19-Mar-90 Pervin Changed :tile to :stipple. Added reference to *twm-bug* ;;; 12-Mar-90 Pervin Setting :title and :icon-title of windows ;;; in :initialize method. ;;; 28-Feb-90 Pervin Fixed bug in set-window-cursor. ;;; Now it works in Lucid and Allegro too! ;;; 14-Feb-90 Pervin Commented out body of set-window-cursor. ;;; 13-Feb-90 Pervin Implemented color. ;;; 5-Dec-89 Pervin Moved new-garnet-window-name to new-defs.lisp ;;; (in-package "OPAL") ;;; Windows ;;; Class Window ;;; To create a window for displaying gobs, create a schema which is an ;;; instance of the window class described below specifying slots as ;;; needed. For example: ;;; ;;; (create-instance my-window opal:window ;;; (:width 100) ;;; (:height 100)) ;;; (define-method :point-in-gob opal::window (gob x y) (and (<= 0 x (g-value gob :width)) (<= 0 y (g-value gob :height)))) ;;; A couple routines useful for windows with backing store ;;; Create a buffer the same size as drawable. (defun create-x-buffer (a-window) (let ((pixmap (gem:create-pixmap a-window (g-value a-window :width) (g-value a-window :height) (gem:window-depth a-window)))) ;; We need to associate a window pointer with the pixmap, in order to ;; be able to find the method. (gem:set-drawable-to-window a-window pixmap) pixmap)) ;;; Initalize the buffer to be background color. (defun clear-buffer (a-window) (gem:clear-area a-window nil nil nil nil T)) ;;; Create new larger buffer. (defun expand-buffer (a-window) (gem:delete-pixmap a-window (g-value a-window :buffer)) (s-value a-window :buffer (create-x-buffer a-window))) ;;; Map-notify is called when a :map-notify event occurs. ;;; It always sets the :visible slot of the window to T. (defun Map-Notify (event-debug a-window) (when event-debug (format t "map-notify ~S~%" a-window ;; DZG (xlib:window-id event-window) )) (if a-window (kr:with-demon-disabled (g-value opal::window :invalidate-demon) (s-value a-window :visible t))) t) (defvar *exit-main-event-loop-function* NIL) (defvar *inside-main-event-loop* nil) ;; returns t if any top level window is visible (defun any-top-level-window-visible () (dolist (win *garnet-windows*) (when (and (schema-p win) (g-value win :visible) (not (g-value win :parent))) (return-from any-top-level-window-visible t))) #| (maphash #'(lambda (xwin win) (declare (ignore xwin)) (when (and (schema-p win) (g-value win :visible) (not (g-value win :parent))) (return-from any-top-level-window-visible t))) *drawable-to-window-mapping*) |# NIL) ;;; Unmap-notify is called when an :unmap-notify event occurs. ;;; It sets the :visible slot of the unmapped window as follows, ;;; T --> :iconified (invoked after the window is iconified ;;; by hand) ;;; :iconified --> :iconified (invoked after opal:iconify-window) ;;; NIL --> NIL (invoked after the window is made ;;; invisible) ;;; If no more window is visible and we are in a main-event-loop, ;;; then leave that event-loop. (defun Unmap-Notify (event-debug a-window) (when event-debug (format t "unmap-notify ~S~%" a-window ;; DZG (xlib:window-id event-window) )) (when (schema-p a-window) (if (g-value a-window :visible) (with-demon-disabled (g-value opal::WINDOW :invalidate-demon) (s-value a-window :visible :iconified))) (if (and *exit-main-event-loop-function* (not (any-top-level-window-visible))) (funcall *exit-main-event-loop-function*))) t) (defun Circulate-Notify (event-debug) (when event-debug (format t "circulate-notify~%")) t) (defun Gravity-Notify (event-debug) (when event-debug (format t "gravity-notify~%")) t) #+clx-mit-r4 ;;; From file windows.lisp ;;; This was marked #+clx-mit-r4; is it still needed, or should we get rid of ;;; it? (defun iconify-window (a-window) (let ((drawable (g-value a-window :drawable))) (when drawable (s-value a-window :visible :iconified) (gem:set-window-property a-window :visible :iconified) (gem:flush-output a-window)))) #-clx-mit-r4 (defun iconify-window (a-window) (declare (ignore a-window))) (defun deiconify-window (a-window) (s-value a-window :visible t) (update a-window)) (defun raise-window (a-window) (cond ((is-a-p a-window opal::window) (let ((drawable (g-value a-window :drawable))) (when drawable (gem:raise-or-lower a-window T)) ;; if drawable was NIL, window will appear on top anyway. (update a-window) ;; if there were no invalid objects in the window, update wouldn't ;; have called display-force-output (gem:flush-output a-window))) (t (error "~S is not a real Opal window~%" a-window)))) (defun lower-window (a-window) (cond ((is-a-p a-window opal::window) (let ((drawable (g-value a-window :drawable))) (unless drawable (setq drawable (create-x-drawable a-window))) (gem:raise-or-lower a-window NIL) (update a-window) ;; if there were no invalid objects in the window, update wouldn't ;; have called display-force-output (gem:flush-output a-window))) (t (error "~S is not a real Opal window~%" a-window)))) #| Zoom operation: If :zoomdims are NIL, then store the window's dims in :zoomdims, and zoom the window else restore the window's dims to :zoomdims, and clear :zoomdims |# (defun zoom-window (a-window &optional fullzoom?) (when (is-a-p a-window window) (let ((zoomdims (g-local-value a-window :zoomdims))) (if zoomdims (progn (s-value a-window :zoomdims NIL) (s-value a-window :top (aref zoomdims 0)) (s-value a-window :left (aref zoomdims 1)) (s-value a-window :width (aref zoomdims 2)) (s-value a-window :height (aref zoomdims 3))) ;;else no zoomdims, so store zoomdims and zoom! (let ((top (g-value a-window :top )) (left (g-value a-window :left )) (width (g-value a-window :width )) (height (g-value a-window :height))) (s-value a-window :zoomdims (make-array 4 :initial-contents (list top left width height))) (s-value a-window :top 0) (s-value a-window :height *screen-height*) (when fullzoom? (s-value a-window :left 0) (s-value a-window :width *screen-width*)))) (update a-window)))) (defun fullzoom-window (a-window) (zoom-window a-window T)) (defun convert-coordinates (win1 x y &optional win2) (multiple-value-bind (xc yc) (gem:translate-coordinates (if win1 win1 (g-value DEVICE-INFO :current-root)) win1 x y win2) (if xc ;; Low-level conversion is better. (values xc yc) ;; If not, do it purely in Opal terms. (let ((left1 (if win1 (g-value win1 :left) 0)) (top1 (if win1 (g-value win1 :top) 0)) (left2 (if win2 (g-value win2 :left) 0)) (top2 (if win2 (g-value win2 :top) 0))) (values (- (+ x left1) left2) (- (+ y top1) top2)))))) (defun simple-initialize-window-border-widths (a-window border-width) (s-value a-window :left-border-width border-width) (s-value a-window :top-border-width border-width) (s-value a-window :right-border-width border-width) (s-value a-window :bottom-border-width border-width)) (defun initialize-window-border-widths (a-window drawable) (gem:initialize-window-borders a-window drawable)) (defun Configure-Notify (event-debug x y width height a-window above-sibling) (if event-debug (format t "Configure-notify win=~s ~s ~s ~s ~s ~s~%" a-window ;; DZG (xlib:window-id event-window) x y width height above-sibling)) (if a-window (let* ((drawable (g-value a-window :drawable)) (event-window drawable)) (when (g-value a-window :visible) ;; szekely: added test for window being visible. This ;; eliminates the problem of the configure notify that olwm ;; sends before mapping a window. (if (g-value a-window :parent) (progn ; If it's a subwindow, we don't (s-value a-window :left x) ; have to check lineage. (s-value a-window :top y)) (unless (eq (g-value a-window :visible) :iconified) (gem:set-window-property a-window :EVENT-POSITION (list x y event-window)))) (unless (or (g-value a-window :already-initialized-border-widths) (eq (g-value a-window :visible) :iconified)) (initialize-window-border-widths a-window event-window) (s-value a-window :already-initialized-border-widths t)) (s-value a-window :width width) (s-value a-window :height height) ;; Don't want top, left, width, height to be invalid, ;; or else we might get a drifting window. (let ((win-info (g-value a-window :win-update-info))) (setf (win-update-info-invalid-slots win-info) (set-difference (win-update-info-invalid-slots win-info) '(:left :top :width :height)))) (when (gem:window-has-grown a-window width height) (expand-buffer a-window) ;; Sometimes the grow icon is not drawn, but calling this function ;; additionally draws the expansion lines along the right and bottom ;; sides of the window. ;; #+apple (traps:_DrawGrowIcon (ccl:wptr drawable)) ;; This update will redraw contents of window into new buffer. (update a-window t)) (opal:update-all)))) t) (defun Exposure (event-debug a-window count x y width height display) (declare (ignore display)) (if event-debug (format t "exposure, count = ~S window-id=~s~%" count (gem:window-debug-id a-window))) (if (schema-p a-window) (let ((drawable (g-value a-window :drawable))) (if drawable ;; Do not update the window in the case where the window ;; was just created and mapped for the first time (if (g-local-value a-window :very-first-exposure) (when (zerop count) (kr:destroy-slot a-window :very-first-exposure)) (let* ((win-ui (get-local-value a-window :win-update-info)) (exposed-bbox (win-update-info-exposed-bbox win-ui))) (unless exposed-bbox (setq exposed-bbox (setf (win-update-info-exposed-bbox win-ui) (opal::make-bbox :valid-p NIL)))) (if (bbox-valid-p exposed-bbox) ;; already valid, so merge into existing bbox (setf (bbox-x2 exposed-bbox) (max (+ x width) (bbox-x2 exposed-bbox)) (bbox-y2 exposed-bbox) (max (+ y height) (bbox-y2 exposed-bbox)) (bbox-x1 exposed-bbox) (min x (bbox-x1 exposed-bbox)) (bbox-y1 exposed-bbox) (min y (bbox-y1 exposed-bbox))) ;; invalid, so copy in and make valid (setf (bbox-valid-p exposed-bbox) T (bbox-x2 exposed-bbox) (+ x width) (bbox-y2 exposed-bbox) (+ y height) (bbox-x1 exposed-bbox) x (bbox-y1 exposed-bbox) y)) (when (zerop count) (s-value a-window :exposed-bbox exposed-bbox) (kr-send a-window :update a-window t) (s-value a-window :exposed-bbox nil) (setf (bbox-valid-p exposed-bbox) NIL))))))) t) (defun display-info-printer (s stream ignore) (declare (ignore ignore)) (format stream "#" (display-info-display s))) (defun initialize-display (root-window) (unless opal:diamond-fill ;; Moved here from halftones.lisp. Used to be done at load time. (setf opal:diamond-fill (make-filling-style '((1 1 1 1 1 1 1 1 1) (1 1 1 1 0 1 1 1 1) (1 1 1 0 0 0 1 1 1) (1 1 0 0 0 0 0 1 1) (1 0 0 0 0 0 0 0 1) (1 1 0 0 0 0 0 1 1) (1 1 1 0 0 0 1 1 1) (1 1 1 1 0 1 1 1 1) (1 1 1 1 1 1 1 1 1)) :root-window root-window))) (unless *halftone-table* ;;; This used to be done by a DefVar, but now the DefVars all occur at ;; the start of loading Opal, before the function is defined, so we must ;; Setf it here... (setf *halftone-table* (build-halftone-table root-window)) (install-bitmap-images)) (gem:initialize-device root-window)) ;; The PAIR argument can either be ;; 1) A dotted pair of two bitmaps: an image and a mask ;; 2) A three-element list consisting of a font and two indices into the font ;; indicating a cursor character and its mask ;; 3) Same as #2 only with :CURSOR as the first element instead of a font. ;; In this case, opal:CURSOR-FONT is used as the font. ;; (defun set-window-cursor (a-window drawable pair) (declare (ignore drawable)) ;; NIY for Mac #+apple (declare (ignore a-window pair)) #-apple ;; First, look up the bitmap pair in the association list of known cursors (let ((old-cursor (cdr (assoc pair (g-value a-window :cursor-pairs) :test #'equal)))) (if old-cursor (gem:set-window-property a-window :CURSOR old-cursor) ;; Haven't seen this bitmap pair before in this window. Create ;; a new cursor pixmap, which will be used to create a new cursor. (let ((pair-car (car pair)) (new-cursor NIL)) (cond ((is-a-p pair-car opal:bitmap) (let ((cursor-bm (g-value pair-car :image))) (multiple-value-bind (cursor-width cursor-height) (gem:image-size a-window cursor-bm) (let ((cursor-pm (gem:create-pixmap a-window cursor-width cursor-height 1)) (mask-bm (g-value (cdr pair) :image)) (mask-pm nil) (mask-width nil) (mask-height nil)) ;; Write the mask into the cursor pixmap (when mask-bm (multiple-value-bind (width height) (gem:image-size a-window mask-bm) (setf mask-pm (gem:create-pixmap a-window (setf mask-width width) (setf mask-height height) 1))) (gem:copy-to-pixmap a-window mask-pm mask-bm mask-width mask-height)) ;; Write the bitmap into the cursor pixmap (gem:copy-to-pixmap a-window cursor-pm cursor-bm cursor-width cursor-height) ;; Create a new cursor with the cursor pixmap (multiple-value-bind (x y) (gem:image-hot-spot a-window cursor-bm) (setf new-cursor (gem:create-cursor a-window cursor-pm (if mask-bm mask-pm) (g-value opal:black :xcolor) (g-value opal:white :xcolor) NIL ;; not from-font (or x 0) (or y 0)))) (gem:set-window-property a-window :CURSOR new-cursor) (gem:delete-pixmap a-window cursor-pm) (if mask-bm (gem:delete-pixmap a-window mask-pm)))))) ((or (eq pair-car :CURSOR) (is-a-p pair-car opal:font-from-file)) (let* ((font (if (eq pair-car :CURSOR) opal::CURSOR-FONT pair-car)) (cursor-char (second pair)) (mask-char (third pair))) (setf new-cursor (gem:create-cursor a-window font font (g-value opal:black :xcolor) (g-value opal:white :xcolor) T ;; from font cursor-char mask-char)) (gem:set-window-property a-window :CURSOR new-cursor))) (t (error "Can't parse cursor spec ~S.~%" pair))) ;; Store the cursor in case we see this pair again (push (cons pair new-cursor) (g-value a-window :cursor-pairs)) ))) t) (defun Change-Cursors (pair &optional a-window-list) (let ((window-list (or a-window-list *garnet-windows*)) (root NIL)) (dolist (a-window window-list) ;; Don't change the cursor of windows that don't have drawables yet. ;; Identify these beasties via their :display-info slot. (let ((display-info (g-value a-window :display-info))) (when display-info (Set-Window-Cursor a-window (g-value a-window :drawable) pair) (or root (setf root a-window))))) (if root (gem:flush-output root)))) (defun Restore-Cursors (&optional a-window-list) (let ((window-list (or a-window-list *garnet-windows*)) (root NIL)) (dolist (a-window window-list) (let ((display-info (g-value a-window :display-info))) (when display-info (Set-Window-Cursor a-window (g-value a-window :drawable) (g-value a-window :cursor)) (or root (setf root a-window))))) (if root (gem:flush-output root)))) (defmacro With-Cursor (cursor &body body) `(unwind-protect (progn (opal:change-cursors ,cursor) ,@body) (opal:restore-cursors))) (defmacro With-HourGlass-Cursor (&body body) `(unwind-protect (progn (opal:change-cursors opal:HourGlass-Pair) ,@body) (opal:restore-cursors))) ;;; Set the :window slot of the window to be the window itself! ;;; (define-method :initialize opal::window (a-window) (call-prototype-method a-window) (let ((win-info (make-win-update-info)) (a-window-update-info (g-local-value a-window :update-info))) (unless (or (g-local-value a-window :title) (let ((proto-title (get-value a-window :title))) (and proto-title (or (formula-p proto-title) ;; If proto does not have a default "Opal N" title ;; (i.e., trimming "Opal " from it does not make a ;; difference), then do not set the :title slot. (string= proto-title (string-left-trim "Opal " proto-title)))))) (s-value a-window :title (new-garnet-window-name))) (unless (g-local-value a-window :icon-title) (s-value a-window :icon-title (g-value a-window :title))) (s-value a-window :win-update-info win-info) (if a-window-update-info (s-value a-window :window (setf (update-info-window a-window-update-info) a-window))) (pushnew a-window *garnet-windows*) (let ((parent (g-value a-window :parent))) (if parent ;; dzg - 11-27-1991 (s-value parent :child (cons a-window (g-local-value parent :child))))) (setf (win-update-info-new-bbox win-info) (make-bbox)) ;;; Clip-mask-1 is the last four elements of clip-mask-2. (setf (win-update-info-clip-mask-1 win-info) (cddddr (setf (win-update-info-clip-mask-2 win-info) (make-list 8)))))) ;;; Sets the icon of a window to be a particular pixmap. (defun set-wm-icon (a-window bitmap-file) (if bitmap-file (if (stringp bitmap-file) (if (probe-file bitmap-file) (let ((image (opal:read-image bitmap-file a-window))) (multiple-value-bind (width height) (gem:image-size a-window image) (opal::build-pixmap a-window image width height t))) (format t "Warning: Icon bitmap file ~A does not exist." bitmap-file)) (warn "Warning: the :icon-bitmap slot of a window should be NIL or a string." )))) ;;; Sets the gcontext-subwindow-mode of the gcontexts of a window's display. (defun set-subwindow-mode (a-window mode) (gem:set-window-property a-window :SUBWINDOW-MODE mode)) ;;; This now returns the drawable it creates. ;;; (defun create-x-drawable (a-window) (let ((display-info (initialize-display a-window))) ;; Make sure the window has an attached display-info. (setf (g-value a-window :display-info) display-info) (multiple-value-bind (black-pixel #+comment white-pixel) (gem:black-white-pixel a-window) (let* ((title-name (g-value a-window :title)) (left (g-value a-window :left)) (top (g-value a-window :top)) (border-width (g-value a-window :border-width)) (width (g-value a-window :width)) (height (g-value a-window :height)) (parent (or (g-value a-window :parent) ;; dzg & amickish -- use the root window of the ;; current device. (g-value device-info :current-root))) ;; NIL background-color means white (background (gem:color-to-index a-window (g-value a-window :background-color))) (drawable (gem:create-window parent left top width height title-name (or (g-value a-window :icon-title) title-name) background border-width (if (g-value a-window :save-under) :on :off) ;; The visible parameter should be T or NIL for ;; the Mac, and something completely bizarre for X. #-apple (if (eq (g-value a-window :visible) :iconified) :iconic :normal) #+apple (g-value a-window :visible) (g-value a-window :min-width) (g-value a-window :min-height) (g-value a-window :max-width) (g-value a-window :max-height) (not (g-value a-window :position-by-hand)) (not (g-value a-window :position-by-hand)) (if (g-value a-window :omit-title-bar-p) :on :off)))) (gem:set-drawable-to-window a-window drawable) (set-wm-icon a-window (g-value a-window :icon-bitmap)) (if (g-value a-window :draw-on-children) (set-subwindow-mode a-window :include-inferiors)) (setf (g-value a-window :drawable) drawable) (if (g-value a-window :double-buffered-p) (let ((buffer (create-x-buffer a-window))) (s-value a-window :buffer buffer) (gem:set-window-property a-window :BUFFER-GCONTEXT (list buffer black-pixel background)) (clear-buffer a-window))) (s-value a-window :top-border-width border-width) (s-value a-window :left-border-width border-width) (s-value a-window :bottom-border-width border-width) (s-value a-window :right-border-width border-width) ;; Andyism = minor Edism + verbose comment ;; ;; The :very-first-exposure slot was invented for X windows to prevent ;; redundant redrawing of the window as it was mapped. If this slot is ;; set on the Mac, then scrolling-windows will not be drawn properly -- ;; the scroll-bars will be erased as the contents are drawn. Note that ;; by allowing exposure events to be handled, we are observing the Mac ;; convention of allowing drawing to be done by the view-draw-contents ;; method. Unfortunately, we are ALSO clinging to the traditional ;; Garnet way of explicitly updating windows on command. Since both ;; strategies are being allowed, top-level windows will be redundantly ;; redrawn as they are mapped. If you are interested in this line of ;; code, you will probably also be interested in the ccl:validate-view ;; instruction at the end of the update method. #-apple (s-value a-window :very-first-exposure t) ;; set the cursor to hemlock's cursor or specified cursor/mask combo ;; (cursor-file . mask-file) (set-window-cursor a-window drawable (g-value a-window :cursor)) ;; bring up the window, and display it (if (g-value a-window :visible) (gem:map-and-wait a-window drawable)) (s-value a-window :old-parent (g-value a-window :parent)) drawable)))) (defun fix-window-properties (a-window changed-slots drawable) (let ((make-new-buffer nil) (map-window-at-end-of-fix-properties nil)) (gem::batch-changes (drawable) (dolist (slot changed-slots) (case slot ((:aggregate :drawable) ;; not done (let* ((win-info (g-value a-window :win-update-info)) (old-agg (win-update-info-old-aggregate win-info)) (agg (g-value a-window :aggregate))) (set-window-cursor a-window drawable (g-value a-window :cursor)) (unless (eq old-agg agg) (if (and (kr:schema-p old-agg) (eq (g-value old-agg :window) a-window)) (set-display-slots old-agg NIL NIL)) (if agg (set-display-slots agg a-window T)) (setf (win-update-info-old-aggregate win-info) agg) (if (and old-agg (null agg)) (gem:clear-area a-window drawable))))) (:parent ;; not checked (let ((old-parent (g-value a-window :old-parent)) (new-parent (g-value a-window :parent)) (left (g-value a-window :left)) (top (g-value a-window :top))) (unless (eq old-parent new-parent) ;; first, fix old-parent's :child slot (if (schema-p old-parent) (s-value old-parent :child (delete a-window (g-value old-parent :child)))) ;; then update new-parent's :child slot (if (schema-p new-parent) (s-value new-parent :child (pushnew a-window (g-value new-parent :child)))) ;; then update slots of the window itself (s-value a-window :lineage nil) (s-value a-window :old-parent new-parent) ;; and, finally, tell X to reparent the drawable (gem:reparent a-window new-parent drawable left top)))) (:cursor (set-window-cursor a-window drawable (g-value a-window :cursor))) (:title (gem:set-window-property a-window :TITLE (g-value a-window :title))) (:icon-title (gem:set-window-property a-window :ICON-TITLE (g-value a-window :icon-title))) (:left (gem:set-window-property a-window :LEFT (+ (g-value a-window :left) (g-value a-window :left-border-width)))) (:top (gem:set-window-property a-window :TOP (+ (g-value a-window :top) (g-value a-window :top-border-width)))) (:width (setf make-new-buffer (or (gem:set-window-property a-window :WIDTH (g-value a-window :width)) make-new-buffer))) (:height (setf make-new-buffer (or (gem:set-window-property a-window :HEIGHT (g-value a-window :height)) make-new-buffer))) (:background-color (gem:set-window-property a-window :BACKGROUND-COLOR (g-value a-window :background-color))) (:icon-bitmap (set-wm-icon a-window (g-value a-window :icon-bitmap))) (:draw-on-children (if (g-value a-window :draw-on-children) (set-subwindow-mode a-window :include-inferiors) (set-subwindow-mode a-window :clip-by-children))) (:save-under (gem:set-window-property a-window :background-color (if (g-value window :save-under) :on :off))) (:visible (setf map-window-at-end-of-fix-properties (or (gem:set-window-property a-window :VISIBLE (g-value window :visible)) map-window-at-end-of-fix-properties)))))) ;; Do this last so that window does not momentarily flicker ;; in its old position (if map-window-at-end-of-fix-properties (gem:map-and-wait a-window drawable)) ;; Expand buffer after the with-state, but within let. (if make-new-buffer (expand-buffer a-window)))) (define-method :destroy-me opal::window (a-window) ;; first recursively destroy all subwindows (dolist (child (g-value a-window :child)) (when (eq a-window (g-value child :parent)) (destroy child))) ;; remove window from parent (if not top-level) (let ((parent (g-value a-window :parent))) (if parent (s-value parent :child (delete a-window (g-local-value parent :child))))) ;; then destroy main window (let ((drawable (g-value a-window :drawable))) (when drawable (setf *garnet-windows* (delete a-window *garnet-windows*)) (gem:delete-window a-window drawable) (gem:flush-output a-window))) (let ((agg (g-value a-window :aggregate))) (when agg (destroy agg nil))) (s-value a-window :window nil) ;; destroy the backing store (let ((buffer (g-value a-window :buffer))) (if buffer (gem:delete-pixmap a-window buffer T))) (call-prototype-method a-window)) (define-method :destroy opal::window (a-window) (dolist (instance (copy-list (g-local-value a-window :is-a-inv))) (destroy instance)) (destroy-me a-window) (when (and *exit-main-event-loop-function* (not (any-top-level-window-visible))) (funcall *exit-main-event-loop-function*))) (define-method :flush opal::window (a-window) (gem:flush-output a-window)) ;;; The following two functions have been added to be used by interactors. ;;; They are exported from Opal. (defun Get-X-Cut-Buffer (window) (if window (gem:get-cut-buffer window) ;; else return the empty string "")) (defun Set-X-Cut-Buffer (window newstring) (if window (gem:set-cut-buffer window newstring)))