;;;
;;;              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/screen-object.sc,v 1.4 90/04/01 13:51:26 johani Exp $

;;; The SCIX Screen Object.

;;; Screens are a special subclass of display in that it inherits a special
;;; instance of display rather than the display class. This facilitates several
;;; screens to use and change the same display object's local state, which is
;;; exactly what is needed to make it possible to replace the dpy parameter
;;; everywhere with a screen ditto.

;;; Note: We want the screen object to inherit more or less all the display
;;; object methods but it should also export the contents of the root-data
;;; object. The really beautiful way to achieve that would be if it was
;;; possible to inherit both the display instance and the root-data instance.
;;; That is possible now...

(define-class (screen root-data dpy)
  (locals
   (whitepixel (make-color 0 0 0))
   (blackpixel (make-color 0 0 0))
   (visuals #f)
   (root-visual #f) )
  (inherit root-data dpy)
  (methods
   (whitepixel (lambda () whitepixel))
   (blackpixel (lambda () blackpixel))
   (root-visual (lambda () root-visual))
   (visuals (lambda () visuals))

   ;; Messages mapped directly on X requests
   (listinstalledcolormaps (lambda rest	         ; #83: ListInstalledColormaps
			     (let ((r (send-listinstalledcolormaps me rest)))
			       (if (x-reply? r)
				   (r 'cmaps)
				   r))))
   ;; #92: LookupColor -- returns a list of two lists - the first list contains
   ;; the exact RGB values, and the second list contains the visual RGB values.
   (lookupcolor (lambda (name . rest)
		  (let ((reply (send-lookupcolor name me rest)))
		    (if (x-reply? reply)
			(list
			 (list (reply 'exact-red)
			       (reply 'exact-green)
			       (reply 'exact-blue) )
			 (list (reply 'visual-red)
			       (reply 'visual-green)
			       (reply 'visual-blue) ))
			#f)))) )

  (init
   (whitepixel 'set-pixel! (me 'white-pixel))
   (blackpixel 'set-pixel! (me 'black-pixel))
   ;; Insert the visuals in the "known id space"
   (set! visuals (map (lambda (d)
			(cons (d 'depth)
			      (map (lambda (v)
				     (make-visual v me (v 'id) ))
				   (d 'visuals) )))
		      (me 'allowed-depths) ))
   (set! root-visual ((dpy 'scix-id-vector) 'lookup (root-data 'root-visual)))
   ))