;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Written 06/14/89 08:33:49 by marky,
;;; Reason: Changes to dual-monitor code to correct run-bar bugs and 
;;; garbage collect killed screens and miscellaneous changes.
;;; while running on LIBRA from band LODA
;;; With SYSTEM 6.5, VIRTUAL-MEMORY 6.1, EH 6.1, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.1, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.2, Inconsistent TV 6.7, DATALINK 6.0, CHAOSNET 6.0, GC 6.2, MEMORY-AUX 6.0,
;;;  NVRAM 6.0, SYSLOG 6.0, STREAMER-TAPE 6.2, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0,
;;;  ZWEI 6.1, DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.0,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.1, TI-CLOS 6.5, CLEH 6.3, IP 3.46,
;;;  Experimental BUG 11.7, Experimental CLX 6.1, CLUE 6.5, X11M 6.1, MMON 1.0, COLOR-MAP-EDITOR 6.0,
;;;   microcode 429, Band Name: sle 6/5 pathes kill2

;;;  SPR's 9980, 9802, 9972, 8861, 9786(duplicate 9782 9783), 10038

;; correct doc string (for patch only )
(SETF (DOCUMENTATION 'tv:*dual-monitors* 'variable)
  "Flag for whether the system is being used in Dual Monitor mode or not.
Gets set when someone executes (tv:make-dual) or (tv:switch-to-dual).")


#!C
; From file SHWARM.LISP#> WINDOW; SYS:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SHWARM.#"

;; SPR 9802
(DEFUN initial-screen-setup ()
  "Finds or creates an acceptable initial screen and assigns it to *INITIAL-SCREEN*.
If INITIAL-LISP-LISTENER exists, forces it to be a legal inferior of *INITIAL-SCREEN*.
ALSO finds or creates the who-line-screen for *initial-screen*."
  (SETF who-line-screen (find-or-create-acceptable-initial-who-line-screen))
  (SETF *initial-screen* (find-or-create-acceptable-initial-screen)) ;; NEEDS who-line-screen !
  ;; Make INITIAL-LISP-LISTENER a valid inferior of *INITIAL-SCREEN*...
  (WHEN (AND initial-lisp-listener
	     (NOT (MEMBER initial-lisp-listener (sheet-inferiors *initial-screen*) :test #'EQ)))
    ;; May want to move associated suggestions frames at this point also...
    ;; Set-superior may remove INITIAL-LISP-LISTENER from the INFERIORS list of *INITIAL-SCREEN*,
    ;;  but it doesn't invoke the DEACTIVATE daemons...
    (SEND initial-lisp-listener :deactivate)
;;    ;; Remove next line when this logic gets put in :set-superior...
;;    (remove-from-screens-previously-selected-windows initial-lisp-listener)
    ;; Binding this global to T causes conversion to monochrome if necessary, instead or error signalled...
    (LET ((tv:*convert-color-sheet-to-monochrome* t))
      (SEND initial-lisp-listener :set-superior *initial-screen*))
    ;; Set-superior may put INITIAL-LISP-LISTENER on the INFERIORS list of *INITIAL-SCREEN*,
    ;;  but it doesn't invoke the ACTIVATE daemons...
    (SEND initial-lisp-listener :activate)
    ;; may 06/08/89 Added moving of suggestions off frame 
    (when (and (not (or (tv:mac-system-p)
			(si:mp-system-p)))
	       suggestions-off-frame
	       (not (MEMBER suggestions-off-frame (sheet-inferiors *initial-screen*) :test #'eq)))
      (send suggestions-off-frame :deactivate)
      (LET ((tv:*convert-color-sheet-to-monochrome* t))
	(send suggestions-off-frame :set-superior *initial-screen*))
      (send suggestions-off-frame :activate))))
))


#!C
; From file SCREENS.LISP#> WINDOW; SYS:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SCREENS.#"


;; may 06/14/89 Broken out from kill-screen function to implement (screen :after :kill)
(defun kill-screen-pointers (screen)
  (WHEN (mmon-p)
    (DOLIST (monitor (APPEND *all-the-monitors* *unconfigured-monitors*))
      (SEND monitor :send-if-handles :set-currently-exposed-screens
	    (DELETE screen (SEND monitor :send-if-handles :currently-exposed-screens) :test #'EQ))
      (SEND monitor :send-if-handles :set-previously-exposed-screens
	    (DELETE screen (SEND monitor :send-if-handles :previously-exposed-screens) :test #'EQ))))
  (SETF *screens-exposed-at-disk-save*
	(DELETE screen *screens-exposed-at-disk-save* :test #'EQ))
  (SETQ *screens-to-refresh* (REMOVE screen *screens-to-refresh*))
  (remove-from-previously-selected-screens screen)
  
  ;; may 06/14/89 Prevent deexposed windows from pointing to a killed screen.
  ;; Allows garbage collection and prevents errors in (get-screen w:cache-window)
  ;; when the cache-window's superior has been killed.
  (WHEN (OR
	  (OR (AND *mono-sprite-window*
		   (EQ screen (SEND *mono-sprite-window* :superior))
		   (PROG1 t (SETQ *mono-sprite-window* nil)))
	      (AND *color-sprite-window*
		   (EQ screen (SEND *color-sprite-window* :superior))
		   (PROG1 t (SETQ *color-sprite-window* nil))))
	  (and w:sprite-window
	       (send w:sprite-window :superior)
	       (eq (send w:sprite-window :superior) screen))
	  (and w:cache-window
	       (send w:cache-window :superior)
	       (eq (send w:cache-window :superior) screen)))
    ;; We must not leave w:sprite-window (or w:cache-window) pointing to the killed screen
    ;; so we will recreate them with a default superior of w:default-screen which MUST be exposed at this time
    ;; (standard-screen :around :expose) will take care of re-initializing
    ;;  *mono-sprite-window* and *color-sprite-window*
    (w:initialize-sprite-window))
  
  ;; may 06/14/89 Also set these to nil if they get killed
  (loop for sym in '(*color-screen* *color-who-line* *mono-who-line*)
	as sym-value = (SYMBOL-VALUE sym)
	do (AND sym-value
		(EQ screen sym-value)
		(SET sym nil)))
  )

;; may 06/14/89 Rewrote so (kill-screen screen) and (send screen :kill) do essentially the same thing.
(DEFUN kill-screen (screen)
  "Blast screen and anything on it.  Removes it from the known
world.  Frees any memory it was using, we hope."
  (WHEN screen 
    (WHEN (sheet-exposed-p screen)
      (ERROR "Cannot kill an exposed screen.  Select some other screen first."))
    (send screen :kill)
    (BEEP)
    (FORMAT t "~%** Make sure to SETQ all variables pointing to this screen to NIL
so that memory can be garbage collected. **")))

;;; >>> Need to complete mods to allow specifying screens to use and leave others alone.
(DEFUN switch-to-dual (&optional monochrome-screen color-screen (verbose t))
  (when (mmon-p)						;; may 06/14/89
    (error "This function is not available in MMON system. 
            Use (tv:make-dual) or (tv:make-cmc)"))		;; may 06/14/89 
  (WHEN *dual-monitors*
    (CERROR "Proceed anyway." "Already in dual monitor mode."))
  (WHEN (AND monochrome-screen (color-sheet-p monochrome-screen))
    (ERROR "~s is not a monochrome screen." monochrome-screen))
  (WHEN (AND color-screen (NOT (color-sheet-p color-screen)))	;; may 06/14/89 was monochrome-screen SPR 9980
    (ERROR "~s is not a color screen." color-screen))
  (SETQ *dual-monitors* t)
  (setup-mono-plane *default-dual-monitor-monochrome-plane*)  ;; Export this from TV ??
  (DOLIST (screen all-the-screens)
    (SEND screen :setup-property-list (IF (color-sheet-p screen) 7 1)
	  (IF (color-sheet-p screen) :color :monochrome) *default-sib*)
    (SETF (sheet-plane-mask screen)
	  (SEND screen :determine-plane-mask-from-property-list))) 
  (kbd-screen-redisplay-some) ;; refresh *screens-to-refresh*
  (kbd-switch-screens nil)
  (kbd-switch-screens nil)
  (BEEP)
  ;; may 06/14/89 was *terminal-io* which is a closure inside dribble-all
  ;; and cannot be handled by SHEET-PREPARE-SHEET-INTERNAL. SPR 10038 is the same
  ;; problem only SHEET-PREPARE-SHEET-INTERNAL blows up the symbol 'TV:BACKGROUND-STREAM.
  (when verbose
    (LET ((window w:selected-window)) ;; may 06/14/89 
      (WHEN window
	(sheet-home window)
	(send window :clear-eol)	;; may 06/14/89 Don't overwrite existing text without clearing first
	(FORMAT window "Now in dual monitor mode.")))))

;;; >>> For single mode, right thing may be to force all to have plane masks of 255.
(DEFUN switch-to-single (&optional (verbose t))	;; may 06/12/89 
  (when (mmon-p)						;; may 06/14/89 
    (error "This function is not available in MMON system."))	;; may 06/14/89 
  (UNLESS *dual-monitors*
    (CERROR "Proceed anyway." "Already in single monitor mode."))
  (SETQ *dual-monitors* nil)
  (setup-mono-plane *default-monochrome-plane*)  ;; Export this from TV ??
  (DOLIST (screen all-the-screens)
    (SEND screen :setup-property-list
	  (IF (color-sheet-p screen) 8 1) :color *default-sib*)
    (SETF (sheet-plane-mask screen) (SEND screen :determine-plane-mask-from-property-list))
    (WHEN (TYPEP screen 'standard-screen)
      (UNLESS (EQ screen default-screen)
	(SEND screen :deexpose))))
  (kbd-screen-redisplay)
  ;; may 06/14/89 was *terminal-io* which is a closure inside dribble-all
  ;; and cannot be handled by SHEET-PREPARE-SHEET-INTERNAL.
  (when verbose
    (LET ((window w:selected-window))	;; may 06/14/89 
      (WHEN window
	(sheet-home window)
	(send window :clear-eol)	;; may 06/14/89 Don't overwrite existing text without clearing first
	(FORMAT window "Now in single monitor mode.")))))

))


#!C
; From file DEBUG.LISP#> WINDOW; SYS:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; DEBUG.#"



;; may 06/14/89 added defvar
(defvar *deexposed-window-symbols*
	'( w:cache-window w:sprite-window tv:*mono-sprite-window* tv:*color-sprite-window*))

;; may 06/14/89 new
(DEFUN print-deexposed-window-info ()
  (DOLIST (sym *deexposed-window-symbols*)
    (FORMAT t "~%~30s = ~s" sym (symbol-value sym))
    (FORMAT t "~% :superior is ~s" (AND (symbol-value sym) (SEND (SYMBOL-VALUE sym) :superior)))))

;; may 06/14/89 added some variables and simplified code
(DEFUN print-all-info ()
  (DOLIST (sym '(
		 tv:main-screen w:default-screen tv:*current-screens*
		 tv:*initial-screen* tv:mouse-sheet tv:who-line-screen
		 tv:all-the-screens tv:*mono-who-line* tv:*color-who-line* 
		 tv:*screens-to-refresh* 
		 w:selected-window tv:*color-system* tv:*color-screen* 
		 ))
    (FORMAT t "~%~30s : ~s" sym (symbol-value sym)))
  (TERPRI)
  (print-deexposed-window-info))

))

#!C
; From file WHOLIN.LISP#> WINDOW; SYS:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; WHOLIN.#"


(DEFMETHOD (who-line-screen :before :expose) (&rest ignore)
  "This WHO-LINE-SCREEN is going to be the active WHO-LINE-SCREEN, so blow away the current one."
  (UNLESS (OR (EQ who-line-screen self) (NOT who-line-screen))
    ;; Optionally erase the place left by the old WHO-LINE-SCREEN...
    (SEND who-line-screen :deexpose
	  :default *screen-bits-action-at-who-line-deexposure*))
  ;; Only do this for primary C/SIB, run bars can only appear on a monitor attached to the primary. KJF.
  (WHEN (ZEROP (SEND self :sib-number))
    ;; The run bar colors are the same as the window it is in, NOT the screen colors!
    ;; Let the window be the first of the windows that are just below WHO-LINE-DOCUMENTATION-WINDOW
    ;; since we hope that the status line windows ALL have the same colors, whereas the
    ;; documentation window and screen may have different colors. SPR 8861
    (LET-IF (TYPEP NWATCH-WHO-LINE-SHEET 'sheet)
	    ((background-color (SEND NWATCH-WHO-LINE-SHEET :background-color))	;; may 06/14/89 
	     (foreground-color (SEND NWATCH-WHO-LINE-SHEET :foreground-color)))	;; may 06/14/89 
      (IF (color-sheet-p self)
	  (PROGN 
	    (SETF si:%run-bar-on (DPB (LOGXOR #xFF plane-mask)
				      (BYTE 8 8)
				      background-color))
	    (SETF si:%run-bar-off foreground-color))
	  ;; ELSE...
	  (PROGN
	    (SETQ si:%run-bar-on (DPB (LOGXOR #xFF plane-mask)
				      (BYTE 8 8)
				      0))
	    (SETQ si:%run-bar-off #xFF)))
;; Never turn them completely off.  08/03/88 KJF.
;;      ;; ELSE, run bars can only be on primary C/SIB, so turn them off
;;      ;; when who-line is not over primary C/SIB...
;;      (setq si:%run-bar-on #xFF00))
      )))
))

#!C
; From file SHEET.LISP#> WINDOW; SYS:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SHEET.#"



;; may 06/07/89 NEW method
(defmethod (screen :after :kill) ()
  ;; added to merge KILL-SCREEN function in the system code properly.
  (kill-screen-pointers self))

))