window.scm

;;; ezd - easy drawing for X11 displays.
;;;
;;; A WINDOW object maintains the information required for an ezd drawing
;;; window.

;*           Copyright 1990-1993 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       250 University Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

;;; Each WINDOW object is represented by a structure with the following
;;; fields:
;;;
;;;	DISPLAY		display object for X display.
;;;	X		initial window position in pixels
;;;	Y
;;;	WIDTH		initial window size in pixels
;;;	HEIGHT
;;;	NAME		ezd name for the window.
;;;	TITLE		title string for the X window.
;;;	FOREGROUND-NAME	foreground color name.
;;;	BACKGROUND-NAME	background color name.
;;;	FOREGROUND	X pixel for the foreground color.
;;;	BACKGROUND	X pixel for the background color.
;;;	EXPOSED		boolean indicating that the window has been
;;;			initially exposed.
;;;	EXPOSE-BBL	list of bounding boxes defining areas that were
;;;			exposed.
;;;	DAMAGE-BBL	list of bounding boxes defining areas that need to be
;;;			redrawn, but weren't exposed.
;;;	VIEWS		list of views of drawings displayed in the window.  The
;;;			head of the list is the "bottom" view.
;;;	CURSOR		current window cursor
;;;	CURSORS		stack of cursors used by SAVE-CURSOR and RESTORE-CURSOR
;;;			commands.
;;;	GC		graphics context for pixmap operations
;;;	XWINDOW		X windowid for the window.

(define-structure window
    display
    x
    y
    width
    height
    name
    title
    foreground-name
    background-name
    (foreground (if foreground-name
		    (display-color->pixel display foreground-name)
		    (begin (color? 'black)
		    	   (window-foreground-name! self 'black)
			   (display-black display))))
    (background (if background-name
		    (display-color->pixel display background-name)
		    (begin (color? 'white)
		    	   (window-background-name! self 'white)
			   (display-white display))))
    (variable-width (if (<= width 0) width #f))
    (variable-height (if (<= height 0) height #f))
    (exposed #f)
    (expose-bbl '())
    (damage-bbl '())
    (views '())
    (cursor (display-font->cursor display XC_LEFT_PTR))
    (cursors '())
    (gc #f)
    (xwindow (let-temporary ((wa (make-xsetwindowattributes) free-xsetwindowattributes)
                             (gcvals (make-xgcvalues) free-xgcvalues))
                (let* ((dpy (display-dpy display))
		    (screen (display-screen display))
		    (wa (begin
			     (set-xsetwindowattributes-background_pixel! wa
				 (window-background self))
			     (set-xsetwindowattributes-border_pixel! wa
				 (window-foreground self))
			     (set-xsetwindowattributes-colormap! wa
				 (display-colormap display))
			     wa))
		    (xwindow (xcreatewindow dpy
				 (xrootwindow dpy screen)
				 (window-x self)
				 (window-y self)
				 (window-width self)
				 (window-height self)
				 2
				 (display-visual-depth display)
				 INPUTOUTPUT
				 (display-visual display)
				 (bit-or CWBACKPIXEL CWBORDERPIXEL CWCOLORMAP)
				 wa))
		    (gc (xcreategc dpy xwindow 0 gcvals)))
		   (let-temporary ((wmh (make-xwmhints) free-xwmhints))
			(set-xwmhints-flags! wmh 1)
			(set-xwmhints-input! wmh 1)
			(xsetwmhints dpy xwindow wmh))
		   (xstorename dpy xwindow title)
		   (xseticonname dpy xwindow (symbol->string name))
		   (xselectinput dpy xwindow
		       (bit-or KEYPRESSMASK KEYRELEASEMASK
			       EXPOSUREMASK
			       STRUCTURENOTIFYMASK
			       OWNERGRABBUTTONMASK
			       BUTTONPRESSMASK BUTTONRELEASEMASK
			       ENTERWINDOWMASK LEAVEWINDOWMASK
			       POINTERMOTIONMASK))
		   (xdefinecursor dpy xwindow (window-cursor self))
		   (xsetforeground dpy gc (window-background self))
		   (xsetgraphicsexposures *dpy* gc 0)
		   (window-gc! self gc)
		   (set! *name-windows*
			 (cons (list (window-name self) self) *name-windows*))
		   (set! *xwindow-windows*
			 (cons (list xwindow self) *xwindow-windows*))
		   xwindow))))

(define-in-line-structure-access window
    display
    x
    y
    width
    height
    name
    title
    foreground-name
    background-name
    foreground
    background
    variable-width
    variable-height
    exposed
    expose-bbl
    damage-bbl
    views
    cursor
    cursors
    gc
    xwindow)
    
;;; A list of lists of window name and the appropriate WINDOW data structure
;;; is kept in *NAME-WINDOWS*.

(define *name-windows* '())

;;; Convert a window name to the WINDOW data structure.

(define (name->window name)
    (let ((x (assoc name *name-windows*)))
	 (if x (cadr x) (error 'name->window "WINDOW not defined: ~s" name))))

;;; See DRAWING-IN-LAST-EXISTING-WINDOW? (view.sc) to see how
;;; LAST-EXISTING-WINDOW-NAME is used to parse commands.

(define last-existing-window-name #f)

;;; Boolean to check if a window exists.

(define (window-exists? name)
    (if (assoc name *name-windows*)
	(begin (set! last-existing-window-name name)
	       #t)
	#f))

;;; A list of lists of X window id and the appropriate WINDOW data structure
;;; is kept in *XWINDOW-WINDOWS*

(define *xwindow-windows* '())

;;; Convert a X window id to a WINDOW data structure.

(define (xwindow->window xwindow)
    (let ((x (assoc xwindow *xwindow-windows*)))
	 (if x (cadr x) #f)))

;;; A drawing window is created by the following procedure.  If the window
;;; already exists, it is deleted and recreated.

(define (ezd-window name x-y width height fixed-size points title
	    foreground-name background-name)
    (let* ((x (if (pair? x-y)
		  (if points (points->pixels (car x-y)) (car x-y))
		  (points->pixels 144)))
	   (y (if (pair? x-y)
		  (if points (points->pixels (cadr x-y)) (cadr x-y))
		  (points->pixels 144)))
	   (width (if points (points->pixels width) width))
	   (height (if points (points->pixels height) height)))
	  (if (window-exists? name) (window-delete name))
	  (let ((w (make-window *display* x y width height name
		       (or title (symbol->string name))
		       foreground-name background-name)))
            (let-temporary ((hints (make-xsizehints) free-xsizehints))
	       (set-xsizehints-flags! hints USSIZE)
	       (set-xsizehints-width! hints width)
	       (set-xsizehints-height! hints height)
	       (when (pair? x-y)
		     (set-xsizehints-flags! hints
			 (bit-or (xsizehints-flags hints) USPOSITION))
		     (set-xsizehints-x! hints x)
		     (set-xsizehints-y! hints y))
	       (when fixed-size
		     (set-xsizehints-flags! hints
			 (bit-or (xsizehints-flags hints)
				 PMINSIZE PMAXSIZE))
		     (set-xsizehints-min_width! hints width)
		     (set-xsizehints-max_width! hints width)
		     (set-xsizehints-min_height! hints height)
		     (set-xsizehints-max_height! hints height))
	       (xsetnormalhints *dpy* (window-xwindow w) hints)
	       w))))

(define-ezd-command
    `(window ,symbol?
	     (optional ,non-negative? ,non-negative?)
	     ,positive-number? ,positive-number?
	     (optional fixed-size) (optional points)
	     (optional ,string?) (optional ,color?) (optional ,color?))
    "(window name [ x y ] width height [ FIXED-SIZE ] [ POINTS ] [\"<title>\"] [<color> [<color>] ])"
    ezd-window)

;;; A WINDOW is deleted by the following procedure.

(define (window-delete name)
    (let ((self (name->window name)))
	 (for-each
	     (lambda (view) (delete-view name (view-drawing-name view)))
	     (window-views self))
	 (set! *xwindow-windows*
	       (delete (list (window-xwindow self) self) *xwindow-windows*))
	 (set! *name-windows*
	       (delete (list (window-name self) self) *name-windows*))
	 (xdestroywindow (display-dpy (window-display self))
	     (window-xwindow self))
	 (set! *update-display* #t)))

(define-ezd-command
    `(delete-window ,window-exists?)
    "(delete-window window)"
    window-delete)

;;; Cursors are saved and restored by the ezd commands SAVE-CURSOR and
;;; RESTORE-CURSOR.

(define-ezd-command
    `(save-cursor ,window-exists?)
    "(save-cursor window-name)"
    (lambda (name)
	    (let ((self (name->window name)))
		 (window-cursors! self (cons (window-cursor self)
					     (window-cursors self))))))

(define-ezd-command
    `(restore-cursor ,window-exists?)
    "(restore-cursor window-name)"
    (lambda (name)
	    (let* ((self (name->window name))
		   (cursors (window-cursors self)))
		  (when (pair? cursors)
			(let ((cursor (car cursors)))
			     (xdefinecursor *dpy* (window-xwindow self) cursor)
			     (window-cursor! self cursor)
			     (window-cursors! self (cdr cursors))
			     (xflush *dpy*))))))

;;; A new cursor is installed in a window by the ezd command SET-CURSOR.

(define-ezd-command
    `(set-cursor ,window-exists? ,cursor-name?)
    "(set-cursor window-name cursor-name)"
    (lambda (name shape)
	    (let ((self (name->window name))
		  (cursor (display-font->cursor *display*
			      (cursor-name? shape))))
		 (xdefinecursor *dpy* (window-xwindow self) cursor)
		 (window-cursor! self cursor)
		 (xflush *dpy*))))

;;; A bounding box is merged onto a list of non-intersecting bounding boxes by
;;; the following function.  Overlapping bounding boxes are merged into one
;;; that contains both.  Adjacent boxes that are equal in size on the one
;;; dimension are merged.

(define (merge-bbl minx miny maxx maxy bbl)
    (let loop ((old bbl) (new '()))
	 (if (pair? old)
	     (let* ((h (car old))
		    (h-minx (car h))
		    (h-miny (cadr h))
		    (h-maxx (caddr h))
		    (h-maxy (cadddr h)))
		   (cond ((or (>= h-minx maxx) (>= h-miny maxy)
			      (<= h-maxx minx) (<= h-maxy miny))
			  (loop (cdr old) (cons h new)))
			 ((and (= minx h-minx) (= maxx h-maxx) (= maxy h-miny))
			  (merge-bbl minx miny maxx h-maxy (remq h bbl)))
			 ((and (= minx h-minx) (= maxx h-maxx) (= h-maxy miny))
			  (merge-bbl minx h-miny maxx maxy (remq h bbl)))
			 ((and (= miny h-miny) (= maxy h-maxy) (= maxx h-minx))
			  (merge-bbl minx miny h-maxx maxy (remq h bbl)))
			 ((and (= miny h-miny) (= maxy h-maxy) (= h-maxx minx))
			  (merge-bbl h-minx miny maxx maxy (remq h bbl)))
			 (else (merge-bbl (min minx h-minx) (min miny h-miny)
				   (max maxx h-maxx) (max maxy h-maxy)
				   (remq h bbl)))))
	     (cons (list minx miny maxx maxy) new))))

;;; Events related to a WINDOW are processed by the following procedure.  The
;;; only event handling "hardwired" into ezd is for expose events and window
;;; resizing.  The rest of the events are handled by user event handlers.

(define (window-event-handler window event)
    (cond ((eq? (xevent-type event) EXPOSE)
	   (set! *update-display* #t)
	   (window-exposed! window #t)		
	   (window-expose-bbl! window
	       (merge-bbl (xevent-xexpose-x event) (xevent-xexpose-y event)
		   (+ (xevent-xexpose-x event) (xevent-xexpose-width event))
		   (+ (xevent-xexpose-y event) (xevent-xexpose-height event))
		   (window-expose-bbl window))))
	  ((eq? (xevent-type event) CONFIGURENOTIFY)
	   (let ((old-width (window-width window))
		 (old-height (window-height window))
		 (width (xevent-xconfigure-width event))
		 (height (xevent-xconfigure-height event)))
		(when (and (or (not (= width old-width))
			       (not (= height old-height))))
		      (when (eq? window *window*)
			    (set! *width* width)
			    (set! *height* height))
		      (window-width! window width)
		      (window-height! window height)
		      (handle-window-events window 'resize event
			  (list old-width old-height width height))))))
    (handle-when-events window event))

;;; Once there are no pending events, the display's event handler calls the
;;; following procedure to redraw all views in all windows as needed.

(define (redraw-all-windows)
    (let ((visible-event-views '())) 
	 (for-each
	     (lambda (name-window)
		     (let* ((window (cadr name-window))
			    (partitions (partition-views
					    (window-views window))))
			   (set! visible-event-views
				 (append (transform-views
					     (window-views window))
					 visible-event-views))
			   (for-each
			       (lambda (views)
				       (if (pair? views)
					   (let ((view (car views)))
						(redraw-a-partition window
						    views))))
			       partitions)
			   (window-damage-bbl! window '())
			   (window-expose-bbl! window '())))
	     *name-windows*)
	 (drawings-redrawn)
	 (for-each handle-visible-events visible-event-views)))

;;; When changes must be made to a drawing, or additions made to an overlayed
;;; drawing, the image is rendered to a pixmap and then copied to the screen
;;; to reduce screen flashes.

(define *pixmap* #f)

(define *pixmap-height* #f)

(define *pixmap-width* #f)

(define (redraw-a-partition window views)
    (let ((solid-views (let loop ((views views))
			    (if (pair? views)
				(if (and (drawing-is-clear
					     (view-drawing (car views)))
					 (not (drawing-cleared
						  (view-drawing
						      (car views)))))
				    (loop (cdr views))
				    (cons (car views) (loop (cdr views))))
				'())))
	  (bbl '())
	  (clip-minx #f)
	  (clip-miny #f)
	  (clip-maxx #f)
	  (clip-maxy #f))
	 
	 (define (set-clip view)
		 ;;; Define the current clipping region.
		 (set! clip-minx (or (and view (view-clip-minx view)) 0))
		 (set! clip-miny (or (and view (view-clip-miny view)) 0))
		 (set! clip-maxx (or (and view (view-clip-maxx view))
				     (window-width window)))
		 (set! clip-maxy (or (and view (view-clip-maxy view))
				     (window-height window))))
	 
	 (define (add-bbl minx miny maxx maxy)
		 ;;; Add a clipped bounding box to the bounding box list.
		 (if (not (or (<= maxx clip-minx)
			      (<= maxy clip-miny)
			      (>= minx clip-maxx)
			      (>= miny clip-maxy)))
		     (set! bbl (merge-bbl (max minx clip-minx)
				   (max miny clip-miny)
				   (min maxx clip-maxx)
				   (min maxy clip-maxy) bbl))))
	 
	 (define (union-view-graphic compute-bb)
		 ;;; Add a deleted object to the bounding box list.
		 (let* ((bb (compute-bb))
			(minx (car bb))
			(miny (cadr bb))
			(maxx (caddr bb))
			(maxy (cadddr bb)))
		       (if (not (eq? minx maxx))
			   (add-bbl minx miny maxx maxy))))
	 
	 (define (union-view view)
		 ;;; Add changes to a view to the bounding box list.
		 (cond ((view-new view)
			(set-view view '())
			(set-clip view)
			(let loop ((gl (drawing-head (view-drawing view)))
				   (minx #f) (miny #f) (maxx #f) (maxy #f))
			     (if (pair? gl)
				 (let ((bb ((graphic-compute-bb (car gl)))))
				      (loop (cdr gl)
					    (bbmin minx (car bb))
					    (bbmin miny (cadr bb))
					    (bbmax maxx (caddr bb))
					    (bbmax maxy (cadddr bb))))
				 (if minx (add-bbl minx miny maxx maxy)))))
		       ((drawing-cleared (view-drawing view))
			(set-clip view)
			(add-bbl 0 0 (window-width window)
			    (window-height window)))
		       (else (set-view view '())
			     (set-clip view)
			     (for-each
				 union-view-graphic
				 (drawing-damaged (view-drawing view))))))
	 
	 (define (add-additions-to-bbl view)
		 ;;; Add additions in a view to the bounding box list.
		 (set-view view '())
		 (set-clip view)
		 (for-each
		     (lambda (g) (union-view-graphic (graphic-compute-bb g)))
		     (drawing-added-head (view-drawing view))))
	 
	 (define (union-additions-to-underlays vl)
		 ;;; Add additions to lower drawings to the bounding box list.
		 (when (and (pair? vl) (pair? (cdr vl)))
		       (add-additions-to-bbl (car vl))
		       (union-additions-to-underlays (cdr vl))))
	 
	 (define (add-expose-to-bbl)
		 ;;; Add window expose regions to the bounding box list.
		 (for-each
		     (lambda (bb) (add-bbl (car bb) (cadr bb)
				      (caddr bb) (cadddr bb)))
		     (window-expose-bbl window)))
	 
	 (define (add-damage-to-bbl)
		 ;;; Add window expose regions to the bounding box list.
		 (for-each
		     (lambda (bb) (add-bbl (car bb) (cadr bb)
				      (caddr bb) (cadddr bb)))
		     (window-damage-bbl window)))
	 
	 (define (redraw)
		 ;;; Redraw the union of the damaged and exposed areas in
		 ;;; each view in order.
		 (for-each
		     (lambda (view)
			     (redraw-a-view view (clip-bbl-to-view view bbl)))
		     solid-views))
	 
	 (when (window-exposed window)
	       ;;; Compute the union of the view's damaged areas and added
	       ;;; areas to underlaying drawings.
	       (for-each union-view solid-views)
	       (union-additions-to-underlays solid-views)
	       (if (and (not nopixmap) solid-views)
		   ;;; OK to use a Pixmap to avoid flashing the screen.
		   (let ((xwindow (window-xwindow window))
			 (width (window-width window))
			 (height (window-height window)))
			;;; Add additions to the top drawing to bbl
			(add-additions-to-bbl (car (last-pair solid-views)))
			;;; Add exposed and damaged regions clipped by each
			;;; view to bbl
			(for-each
			    (lambda (view)
				    (set-clip view)
				    (add-expose-to-bbl)
				    (add-damage-to-bbl))
			    solid-views)
			;;; Get a pixmap.
			(when (or (not *pixmap*) (< *pixmap-width* width)
				  (< *pixmap-height* height))
			      (if *pixmap* (xfreepixmap *dpy* *pixmap*))
			      (set! *pixmap*
				    (xcreatepixmap *dpy*
					(window-xwindow window)
					width height
					(display-visual-depth *display*)))
			      (set! *pixmap-width* width)
			      (set! *pixmap-height* height))
			(set-view #f '())
			(window-xwindow! window *pixmap*)
			;;; Build clip list and fill pixmap with background.
			(let loop ((l bbl) (rl '()))
			     (if (pair? l)
				 (let ((bb (car l))
				       (r (make-xrectangle)))
				      (set-xrectangle-x! r (car bb))
				      (set-xrectangle-y! r (cadr bb))
				      (set-xrectangle-width! r (- (caddr bb)
							      (car bb)))
				      (set-xrectangle-height! r (- (cadddr bb)
							       (cadr bb)))
				      (loop (cdr l) (cons r rl)))
				 (begin
                                   (xsetcliprectangles *dpy* 
                                            (window-gc window)
                                            0 0 
                                            (xrectangle-list->xrectanglea rl)
				            (length rl) UNSORTED)
                                   (free-rectangle-list rl))))
			(xfillrectangle *dpy* *pixmap* (window-gc window)
			    0 0 width height)
			;;; Draw to pixmap and then copy to the window.
			(redraw)
			(xcopyarea *dpy* *pixmap* xwindow (window-gc window)
			    0 0 width height 0 0)
			(set-view #f '())
			(window-xwindow! window xwindow))
		   ;;; No pixmap, draw directly to the window.
		   (begin (for-each
			      (lambda (view)
				      (set-clip view)
				      (add-damage-to-bbl))
			      solid-views)
			  (for-each
			      (lambda (bb)
				      (xcleararea *dpy*
					  (window-xwindow window)
					  (car bb) (cadr bb)
					  (- (caddr bb) (car bb))
					  (- (cadddr bb) (cadr bb)) 0))
			      bbl)
			  (set-clip #f)
			  (add-expose-to-bbl)
			  (redraw))))))

;;; Once all drawings have been redrawn, then the additions list and the
;;; redraw area can be cleared.

(define *redraw-seq* 0)

(define (drawings-redrawn)
    (for-each
	(lambda (name-drawing)
		(let ((drawing (cadr name-drawing)))
		     (drawing-added-head! drawing '())
		     (drawing-added-tail! drawing '())
		     (drawing-zmotion! drawing #f)
		     (drawing-cleared! drawing #f)
		     (drawing-damaged! drawing '())))
	*drawings*)
    (set! *redraw-seq* (+ 1 *redraw-seq*)))
		      
;;; Module reset/initialization

(define (window-module-init)
    (set! *name-windows* '())
    (set! *xwindow-windows* '())
    (set! *pixmap* #f))