;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, 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.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/objects.sc,v 1.4 90/04/01 13:51:04 johani Exp $

;;; Some SCIX Objects.

;;; Object types closely coupled to the X protocol: drawable pixmap window gc
;;; pointer (in lw) cursor keyboard (in lw) display screen colormap
;;; color (in lw).
;;;

(module objects (top-level make-visual make-drawable
			   make-pixmap make-font make-cursor))

(include "../include/lw-objects.sch")
(include "../include/lowlevel.sch")       ; things used by the display object
(include "../include/requests.sch")
(include "../include/msg-handler.sch")
(include "../include/util.sch")	          ; utilities needed by define-class
(include "../include/masks.sch")

(define-external x-protocol-atoms global)

(include "../macros/extend-syntax.sc")
(include "../macros/define-class.sc")	       ; used to define most objects
(include "../macros/define-lw-class.sc")       ; used to define lw objects

(include "screen-object.sc")

;;; Visuals
(define-class (visual visual-data scr id)
  (inherit visual-data)
  (init
   ((scr 'scix-id-vector) 'insert-with-key! me id) ))

;;; Drawables -- windows and pixmaps.
(eval-when (compile eval load)
  (define-class (drawable width height depth scr id)
    (locals
     (callbacks '()) )
    (inherit
     (resource scr id))
    (methods
     ;; Simple selectors...
     (depth (lambda () depth))
     (width (lambda () width))
     (height (lambda () height))
     ;; ...and mutators. Be careful with these. There be dragons here!
     (set-depth! (lambda (arg) (set! depth arg)))
     (set-width! (lambda (arg) (set! width arg)))
     (set-height! (lambda (arg) (set! height arg)))
     (screen (lambda () scr))
     
     ;; A GC below denotes a member of the disjoint union between the set
     ;; of all gc object instances and {#F} - #F denotes a "nil" gc.
     ;; A graphic object is either simple (a primitive object or a view)
     ;; or a pair P ((car P) is a graphic object and (cdr P) is a GC).
     ;; The object P is called a GC CLOSURE. The graphic object P is always
     ;; interpreted using the outermost non "nil" bound GC (starting with
     ;; the gc parameter in the DRAW message).
     
     (draw (lambda (obj-list gc . rest)
	     (define (draw-graphic o gc)
	       (if (and (procedure? o) (eq? (o 'object-class) 'view))
		   (for-each (lambda (o)
			       (draw-graphic o gc) )
			     (o 'contents) )
		   (if (pair? o)
		       (draw-graphic (car o) (if gc gc (cdr o)))
		       (o 'draw gc me rest) )))
	     (for-each (lambda (o)
			 (draw-graphic o gc) )
		       obj-list) ))

     ;; Event-handling and callbacks
     (callbacks (lambda () callbacks))

     (add-callback! (lambda (event-kind handler)
		      (let ((cb-l (assq event-kind callbacks)))
			(if cb-l
			    (set-cdr! (last-pair cb-l) (list handler))
			    (set! callbacks (cons (list event-kind handler)
						  callbacks)) ))))
     (set-callbacks! (lambda (l)
		       (set! callbacks l) ))
     
     (remove-callback! (lambda (event-kind handler)
			 (let ((cb-l (assq event-kind callbacks)))
			   (if cb-l
			       (set! cb-l (remq! handler cb-l))
			       #f))))
			    
     ;; How to detect which events are mine and which belong to other windows?
     ;; The problem is that usually it won't be "me" that is the event-window,
     ;; but rather something that has inherited me. But this something (like a
     ;; toggle-button) should always be the same (in a given widget inheritance
     ;; hierarchy only one object can be the top-level one). That is not
     ;; necessarily true in theory, but it must be in practice for this scheme
     ;; to work. Therefore the top-level object is supplied by the event-
     ;; handler in obj. Also note that the message 'my-events! returns a list
     ;; of all consecutive events belonging to this window.
     ;; Note1: for now the callbacks are called with one event at a time, not
     ;;        the msg-handler.
     ;; Note2: the ev-source can be either a list of events or the msg-handler.
     ;;        This is necessary to take care of derived classes with local
     ;;        event-handlers that extract the events from the msg-handler.

     (scix-event-dispatch (lambda (ev-source obj)
			    (let ((ev-l (if (pair? ev-source)
					    ev-source
					    (ev-source 'my-events! obj) )))
			      (let loop ((e (car ev-l)) (ev-l (cdr ev-l)))
				(let ((pare (assq (e 'event-name) callbacks)))
				  (if pare
				      ((cadr pare) e obj)
				      #f))
				(if (not (null? ev-l))
				    (loop (car ev-l) (cdr ev-l)) )))))
     
     ;; Methods mapped directly on X requests.
     (getgeometry (lambda rest		                    ; #14: GetGeometry
		    (send-getgeometry me scr rest) ))
     ;; #62: Copyarea
     (copyarea (lambda (src-d gc src-x src-y dst-x dst-y width height . rest)
		 (send-copyarea src-d me gc src-x src-y
				dst-x dst-y width height scr rest)))
     (copyplane (lambda (src-d gc src-x src-y dst-x dst-y   ; #63: CopyPlane
			       width height bit-plane . rest)
		  (send-copyplane src-d me gc src-x src-y dst-x dst-y
				  width height bit-plane scr rest)))
     (putimage (lambda (fmt gc width height dst-x dst-y     ; #72: PutImage
			    left-pad byte-list . rest)
		 (send-putimage fmt me gc width height dst-x dst-y
				left-pad byte-list scr rest) ))
     (getimage (lambda (fmt x y width height plane-mask . rest) ; #73: GetImage
		 (send-getimage fmt me x y width height
				plane-mask scr rest) ))
     (querybestsize (lambda (class width height . rest)    ; #97: QueryBestSize
		      (let ((reply (send-querybestsize class me width height
						       scr rest)))
			(if (x-reply? reply)
			    (list (reply 'width) (reply 'height))
			    reply))))
     )))

;;; Pixmaps.
(eval-when (compile eval load)
  (define-class (pixmap width height depth scr &optional id)
    (locals
     (drawable (scr 'root)) )
    (inherit
     (drawable width height depth scr (if (null? id)
						  #f
						  (car id))))
    (methods
     (drawable (lambda () drawable))
     (createpixmap (lambda rest			; #53: CreatePixmap
		     (send-createpixmap me scr rest) ))
     (freepixmap (lambda rest			; #54: FreePixmap
		   (me 'scix-denounce-id!)
		   (send-freepixmap me scr rest) )))
    (init
     (if (or (null? id)
	     (not (number? (car id))) )
	 (me 'scix-announce-id! me) ))))

;;; If a 'fill method is wanted for a pixmap it can be inserted like this:
;;; (pmap 'insert-method!
;;;        (fill (lambda (gc)
;;;                (send-polyfillrectangle pmap gc
;;;                                        `(0 0 ,(pmap 'width)
;;;                                              ,(pmap 'height) )
;;;                                         (pmap 'screen) )))))

(include "font-object.sc")
(include "cursor-object.sc")