;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Display
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/display.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 09/21/92 08:22:36
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 05/24/1991 (Hubertus)  changed lambda-list for UPDATE-DISPLAY-DEPENDENCIES:
;;;                        a second EQL parameter ACTION (type (member :open :close))
;;;                        indicates whether the display is opened or closed.
;;;
;;; 11/15/1991 (Matthias) replaced UPDATE-DISPLAY-DEPENDENCIES facility by
;;;                       two hooks *open-display-hooks* and *close-display-hooks*
;;;                       These should only be changed with the macros:
;;;                       add-open-display-hook, add-close-display-hook
;;;                       remove-open-display-hook, add-close-display-hook
;;;
;;; 12/06/1991 (Hubertus) added DISPLAY-INITIALIZED-P for checking the *DISPLAY*
;;;                       variable. 
;;; 08/04/1992 (Matthias) New: display-type-and-version can be used for server
;;;                       dependent patches (e.g. clipmask origin).
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defun init-*same-host-p* (&optional display)
  (declare (special *default-host* *same-host-p*)
	   (ignore display))
  (setq *same-host-p*
      (or (string= *default-host* "unix")
	  (string= *default-host* (host-variable)))))

(defvar *server-types*
    '(("MIT" . :mit)
      ("NeWS" . :openwin)))
      
(defun init-x-server-type (display)
  (declare (special *x-server-type* *x-server-version*))
  (multiple-value-setq (*x-server-type* *x-server-version*)
    (display-type-and-version display))
  (values *x-server-type* *x-server-version*))

(defun display-type-and-version (display)
  (multiple-value-bind (vendor version) (display-vendor display)
     (values (dolist (server-type *server-types*)
	    (when (search (car server-type) vendor)
	      (return (cdr server-type))))
     version)))
 	
(defun do-open-toplevel-display (&optional name &rest display-options)
  (let ((display
      (apply #'open-contact-display (or name 'toplevel-display) display-options)))
  (call-open-display-hooks display)
  display))

(defun open-toplevel-display (&optional name &rest display-options)
  (close-toplevel-display)
  (apply #'do-open-toplevel-display name display-options))

(defun close-toplevel-display ()
  (declare (special *display*))
  (when (and (boundp '*display*) *display*)
    (call-close-display-hooks *display*)
    (close-display *display*))
  (setq *display* nil))

;;; 11/22/1990 (Matthias) added *shading-mask*, *shading-pixmap* should become
;;; obsolete
(defun initialize-toplevel-display-globals (display)
  (declare (special *display* *screen* *root* *white-pixel* *black-pixel*
       	    *shading-image* *shading-pixmap* *shading-mask* *inversion-pixel*))
  (setq *display* display)
  (setq *screen* (display-default-screen *display*))
  (setq *white-pixel* (screen-white-pixel *screen*))
  (setq *black-pixel* (screen-black-pixel *screen*))
  (setq *inversion-pixel* (logxor *black-pixel* *white-pixel*))
  (setq *root* (display-root *display*))
  (setq *shading-pixmap* (convert *root* *shading-image* 'pixmap))
  (setq *shading-mask* (find-simple-mask *root* *shading-image*))
  )
  
(defun display-default-depth (display)
  (screen-root-depth (display-default-screen display)))

(defun color-display-p (display)
  (> (display-default-depth display)  1))

(defun display-initialized-p (&optional display)
  (declare (special *display*))
  (if display
      (not (xlib::display-dead display))
    (and (boundp '*display*)
	 (not (null *display*))
	 (not (xlib::display-dead *display*)))))


;;; Open Display Hooks
;;;

(add-open-display-hook 'init-*same-host-p*)
(add-open-display-hook 'initialize-toplevel-display-globals)
(add-open-display-hook 'init-x-server-type)