;;; -*- 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. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Close all connections to the X server by saying:
;;;     (opal:Disconnect-Garnet)
;;;
;;; While the connection to the X server is closed, you may
;;; save a core image of Garnet.  To save a core image:
;;;   In CMU Common Lisp say        (ext:save-lisp filename)
;;;   In Allegro Lisp say           (excl:dumplisp)
;;;   In Lucid Lisp the command is  (disksave filename)
;;;
;;; Reopen all connections to the X server by saying:
;;;     (opal:Reconnect-Garnet)
;;;
#|
CHANGE LOG:
        17-Apr-94 amickish Restored s-value of :lineage to NIL when disconnect;
                           Destroyed colormap slots after all.
        25-Mar-94 amickish Eliminated redefinition warnings when reconnecting
        15-Dec-93 amickish Do not maintain :display of opal::window; maintain
                    :active-devices of DEVICE-INFO when destroy *root-window*
        18-Nov-93 amickish Destroyed X-DEVICE and *root-window*
        24-May-93 koz      Converted kr::set-slot-accessor calls to use
                           new KR 2.3 format (one more argument)
        19-Apr-93 amickish Destroyed font slots in opal:font-from-files
        24-Feb-93 amickish moved *auxilliary-reconnect-routines* to new-defs
        02-Feb-93 DZG In disconnect-garnet, call kr::set-slot-accessor on the
                      font objects instead of destroy-slot.
        01-Feb-93 amickish all-the-instances ---> do-all-instances
        13-Jan-93 amickish Now sever X connections to fonts rather than texts
        10-Dec-92 amickish *drawable-to-window-mapping* ---> *garnet-windows*
        21-Sep-92 amickish No longer necessary to call notice-items-changed on
                      menubars, due to reimplementation of :submenu-window-list
                      in MENUBAR gadget.
        22-Jun-92 ECP It is necessary to call notice-items-changed on
                      menubars during the execution of reconnect-garnet.
	19-Jun-92 ECP In reconnect-garnet, turn off asynchronous error reports.
	29-May-92 ECP/KY Determine display number and screen number from
		      full display name, by calling initialize-x11-values.
		      If you call disconnect-garnet when already disconnected,
		      or reconnect-garnet when already reconnected, exit.
	25-May-92 ECP Check that elements of *all-windows* and
		      *all-windows-which-have-been-closed* have not
		      been destroyed.
	 6-May-92 ECP Only call main-event-loop-process in reconnect-garnet
		      if it had been halted in disconnect-garnet.
	16-Apr-92 ECP Call launch-main-event-loop-process at end of
		      reconnect-garnet.
        30-Mar-92 amickish  Changed funcalls of :update method to update call;
                      Changed the way *all-the-windows* is computed in
                      Disconnect-Garnet.
        25-Mar-92 amickish  Get-Values ---> G-Value
	23-Mar-92 ECP In reconnect-windows, must update all the windows,
			not just the visible ones.
	20-Mar-92 ECP Moved exports to defs.lisp.  Use process routines.
	11-Mar-92 ECP Added references to kr::*constants-disabled*
		      When reinitializing colors, just call g-value,
		      not s-value.
	17-Feb-92 ECP Added *auxilliary-reconnect-routines*
        31-Jan-92 ECP Eliminated *display-name-to-display-mapping*.
	24-Jan-92 ECP reinitialized text objects in reconnect-garnet.
	26-Mar-91 ECP kcl patch
        24-Mar-91 ECP Fixed bug involving reconnect to a color screen.
         7-Mar-91 ECP The question of whether the screen is color or
                      black-and-white is now determined inside
                      initialize-default-x-values in defs.lisp.
	14-Feb-91 ECP More changes to color for connect and disconnect
         8-Feb-91 ECP Added :color-p slot to opal:color to tell if
                      screen is black-and-white or color.
        11-Sep-90 ECP Get display name in allegro by (sys::getenv "DISPLAY")
                      Use (short-site-name) as an #+allegro alternative
                      to (machine-instance)
        15-Aug-90 ECP Yet more debugging.  Disconnect-garnet must
                      ; set windows :lineage slot to NIL.
                      Reconnect-garnet has an optional argument.
                      Call to initialize-default-x-values.
	14-Aug-90 ECP In reconnect-garnet, just explicitly update
			top level windows.
	10-Aug-90 ECP In reconnect-garnet, recompute display name.
	21-Mar-90 ECP Lots of debugging, as well as the above comments.
	9-Mar-90 ECP Released locally
|#

(in-package "OPAL")

(defvar *all-the-windows* nil)
(defvar *all-windows-which-have-been-closed* nil)
(defvar *garnet-has-been-disconnected* nil)
#-cmu (defvar *main-event-loop-process-was-halted* nil)

(defun do-all-instances (obj a-function &key (self NIL))
  (dolist (inst (g-value obj :is-a-inv))
    (do-all-instances inst a-function :self NIL)
    (funcall a-function inst))
  (if self (funcall a-function obj)))


(defun Destroy-Font-Slots (fnt)
  (if (kr:g-cached-value fnt :xfont)
    (gem:delete-font (g-value device-info :current-root) fnt))
  
  ;;; The calls to kr::set-slot-accessor are conceptually the same
  ;;; as calls to destroy-slot.  Destroying all these local slots will case
  ;;; formulas to be re-inherited and re-evaluated upon reconnection.
  ;;;
  ;;; amickish 11/18/93 - Commented out because font formulas now depend
  ;;; on the DEVICE-INFO schema, and you can make its slots constant if you
  ;;; want the formulas to become constant.
  #+comment
  (progn
    (kr::set-slot-accessor fnt :xfont kr::*NO-VALUE* 0 NIL)
    (kr::set-slot-accessor fnt :char-width kr::*NO-VALUE* 0 NIL)
    (kr::set-slot-accessor fnt :max-char-ascent kr::*NO-VALUE* 0 NIL)
    (kr::set-slot-accessor fnt :max-char-descent kr::*NO-VALUE* 0 NIL)
    (kr::set-slot-accessor fnt :font-height kr::*NO-VALUE* 0 NIL)
    (if (is-a-p fnt opal:font)
	(kr::set-slot-accessor fnt :font-from-file kr::*NO-VALUE* 0 NIL)))
  )


(defun Destroy-Color-Slots (col)
  ;;; Formulas will be re-inherited and re-evaluated upon reconnection
  ;;;
  (progn
    (kr::set-slot-accessor col :xcolor kr::*NO-VALUE* 0 NIL)
    (kr::set-slot-accessor col :colormap-index kr::*NO-VALUE* 0 NIL)))


(defun Disconnect-Garnet ()
  (when *garnet-has-been-disconnected*
    (return-from disconnect-garnet))
  #-cmu
  (when (opal:main-event-loop-process-running-p)
    (setq *main-event-loop-process-was-halted* t)
    (opal:kill-main-event-loop-process))
  #+cmu (ext:disable-clx-event-handling opal::*default-x-display*)
  (setq *all-the-windows* (copy-list *garnet-windows*))
  (setq *all-windows-which-have-been-closed* nil)
  ;;; Make all the windows invisible.
  (dolist (w *all-the-windows*) 
    (when (and (kr:g-value w :visible)
	       (kr:g-value w :drawable))
       (push w *all-windows-which-have-been-closed*)
       (kr:s-value w :visible nil) 
       (update w)))  ; generalized update

  ;;; Remove all connections to X from the font objects, and from update-
  ;;; slots array of text objects
  (opal::do-all-instances opal:font #'Destroy-Font-Slots)
  (opal::do-all-instances opal:font-from-file #'Destroy-Font-Slots)
  (opal::do-all-instances opal:color #'Destroy-Color-Slots)

  (do-all-instances opal:font-from-file
    #'(lambda (fnt)
	(kr:s-value fnt :display-xfont-plist nil))
    :self T)

  (do-all-instances opal:text
    #'(lambda (txt)
	(if (kr:g-cached-value txt :update-slots-values)
	    (setf (aref (kr:g-cached-value txt :update-slots-values)
			opal::*text-xfont*)
		  :closed))))
  
  ;;; Remove all connections to X from the window objects.
  (setf *garnet-windows* NIL)
  (dolist (w *all-the-windows*)
    (kr:s-value w :cursor-pairs nil)
    (kr:s-value w :drawable nil)
    (kr:s-value w :lineage nil)
    (kr:s-value w :already-initialized-border-widths nil)
    (kr:s-value w :event-mask nil)
    (when (kr:g-cached-value w :display-info)
      (kr:s-value w :display-info nil)))
  ;;; Clear all colors.
  (dotimes (n *colormap-index-table-size*)
    (setf (aref *colormap-index-table* n) 0))
  (setq *garnet-has-been-disconnected* T))


(defun Reconnect-Garnet (&optional display-name device-type)
  (unless *garnet-has-been-disconnected*
    (return-from reconnect-garnet))

  (let ((current-device (g-value DEVICE-INFO :current-device))
        root-window)

    (unless device-type
      (setf device-type (g-value current-device :device-type)))
    (s-value DEVICE-INFO :active-devices
	     (delete current-device (g-value DEVICE-INFO :active-devices)))
    (destroy-schema (g-value current-device :root-window))
    (destroy-schema current-device)

    ;; Binding this variable prevents warings when gem::*root-window* and
    ;; gem::x-device are redefined as the image is restarted.
    (let ( #+allegro (excl:*redefinition-warnings* NIL)
           #+apple (ccl:*warn-if-redefine* NIL))
      (gem:init-device device-type display-name))

    (setf root-window (g-value device-info :current-root))

    ;; Should be called in X-Init-Device?
    #-apple
    (opal::set-draw-functions)		; defined in defs.lisp

    (if *is-this-a-color-screen?*
      (let ((indices (gem:colormap-property root-window :ALLOC-COLOR-CELLS)))
	(reset-first-allocatable-colormap-index root-window)
	(set-first-allocatable-colormap-index root-window (car indices))
	(gem:colormap-property root-window :FREE-COLORS indices)))

    ;; Re-initialize fonts
    (with-constants-disabled
	(do-all-instances opal:text
	  #'(lambda (txt)
	      (let ((vals (g-cached-value txt :update-slots-values)))
		(if (and vals (eq (aref vals opal::*text-xfont*) :closed))
		  (setf (aref vals opal::*text-xfont*)
			(s-value txt :xfont (g-value txt :font :xfont))))))))

    (dolist (f *auxilliary-reconnect-routines*)
      (funcall f))

    (dolist (w *all-windows-which-have-been-closed*)
      (unless (already-been-destroyed w)
	(kr:s-value w :visible t)))
    (dolist (w *all-the-windows*)
      (unless (or (already-been-destroyed w)
		  (kr:g-value w :parent))
	(update w T)))
    (setf *garnet-windows* *all-the-windows*)

    #+cmu
    (ext:enable-clx-event-handling opal::*default-x-display*
				   #'inter::default-event-handler)

    #-cmu
    (when *main-event-loop-process-was-halted*
      (opal:launch-main-event-loop-process))

    (gem:set-window-property root-window :REPORT-ASYNCHRONOUS-ERRORS NIL)

    (setq *garnet-has-been-disconnected* nil)
    t))
