;;; -*- 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:
        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" :use '("KR" "LISP"))

(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)
      (xlib:close-font (kr:g-cached-value fnt :xfont)))
  ;;; The calls to kr::set-slot-accessor are conceptually the same
  ;;; as the calls to destroy-slot, commented out below.  We can't
  ;;; use destroy-slot, though, because of something to do with dependencies.
  ;;;
  ;;; Formulas will be re-inherited and re-evaluated upon reconnection
  (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))

  #+COMMENT
  (with-constants-disabled
    (destroy-slot fnt :xfont)
    (destroy-slot fnt :char-width)
    (destroy-slot fnt :max-char-ascent)
    (destroy-slot fnt :max-char-descent)
    (destroy-slot fnt :font-height)
    (destroy-slot fnt :font-from-file)))

(defun Destroy-Color-Slots (col)
  ;;; Formulas will be re-inherited and re-evaluated upon reconnection
  (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)

  (unless *garnet-has-been-disconnected*
    (return-from reconnect-garnet))

  (opal::initialize-x11-values  ;; defined in defs.lisp
    (or display-name (get-full-display-name)))
  (kr:s-value opal::window :display opal::*default-x-display-name*)
  (opal::set-draw-functions)	      ;; defined in basics.lisp

  (let ((kr::*constants-disabled* T))
    (s-value opal:color :color-p *is-this-a-color-screen?*))

  (when *is-this-a-color-screen?*
    (let ((indices (xlib:alloc-color-cells opal::*default-x-colormap* 1)))
      (setq *first-allocatable-colormap-index* (car indices))
      (xlib:free-colors opal::*default-x-colormap* 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))

  (setf (xlib:display-report-asynchronous-errors
	   opal::*default-x-display*)
        nil)

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

  t)


