;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Toplevel
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/toplevel.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 12/15/92 12:43:48
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 09/03/90 [Kalle] make-toplevel generates now a top-level-shell (with
;;;                  setable shell-title) around the toplevel-window
;;;  
;;; 09/07/90 [Kalle] make-toplevel generalized to parameterize
;;;                  toplevel-class and toplevel-display
;;;
;;; 11/19/90 [Hubertus] adapted EVAL-TOPLEVEL-LOOP for multiple values
;;;
;;; 01/29/1991 (Juergen) the argument toplevel-window for the functions toplevel-loop 
;;;                      and eval-toplevel-loop now defaults to *toplevel*
;;;
;;; 02/12/1991 (Matthias) the global vars *, **, *** are set within
;;;                       eval-toplevel-loop as usually.
;;; 04/25/1991 (Matthias) moved identify-window-with-mouse from identifier.lisp
;;;                       into this file
;;;                       Note that window is selected now by button-p r e s s
;;;
;;; 05/13/1991 (Juergen)  New functions start-event-loop and 
;;;                       start-eval-event-loop have been added
;;;                       They are called from toplevel-loop and 
;;;                       eval-toplevel-loop, respectively.
;;;
;;; 05/13/1991 (Juergen)  The tag quit-toplevel-loop has been changed
;;;                       to quit-event-loop.
;;;
;;; 05/13/1991 (Juergen)  eval-toplevel-loop is now a function and no longer
;;;                       a method.
;;;
;;; 05/13/1991 (Juergen)  keyword toplevel-display of function make-toplevel
;;;                       has been changed to display.
;;;                       New keyword shell-class added.
;;; 09/16/1991 (Matthias) New func: (identify-window *toplevel* ...)
;;;
;;; 10/24/1991 (Hubertus) New gf SPECIFY-REGION-WITH-MOUSE for interactively 
;;;                       specifying a region by rubberbanding.
;;;
;;; 10/29/1991 (Juergen)  New function setup-toplevel which asks for the 
;;;                       x server host, opens a display, and makes a toplevel.
;;; 11/18/1991 (Matthias) New function stop-event-loop, does it gracefully.
;;; 02/10/1992 (Matthias) New mixin for toplevel-window: focus-mixin
;;;                       New: Control-C in toplevel is now handled by focus
;;;                       facility via key-press
;;; 02/11/1992 (Matthias) new method: accept-focus-p
;;;
;;; 02/23/1992 (Hubertus) added method confirm-terminating-application, which is 
;;;                       called whenever the user tries to ``delete the toplevel
;;;                       window'' (e.g. by selecting "QUIT" from a window manager
;;;                       menu). This method should return T, iff the system or
;;;                       user decides to complete the deletion. 
;;;                       As part of the confirmation, this method should also
;;;                       perform application-dependent operations to save its
;;;                       internal state, if needed.
;;;
;;; 12/15/1992 (Juergen)  identify-window has been extended to provide a menu 
;;;                       containing the windows in the selected object's
;;;                       window hierarchy when the right mouse button
;;;                       is used for selection.
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

(defcontact toplevel-window (token-event-handler-mixin focus-mixin
			     interaction-window composite)
     ((name :initform :toplevel)
      (reactivity :initform '((:keyboard "C-c: Quit event loop"))))
     (:documentation "class for windows on the toplevel"))

(define-resources
  (* toplevel-window x) 150
  (* toplevel-window y) 150
  (* toplevel-window width) 900
  (* toplevel-window height) 700
  (* toplevel-window background) .25    ;; 25%gray
  (* toplevel-window cursor) "X_cursor")

(defmethod toplevel-window ((self toplevel-window))
  self)

#||
(defevent toplevel-window (:key-press #\Control-\c)
	  ;(throw-action quit-event-loop)
	  (eval-action (stop-event-loop (contact-display *self*))))
||#

;;; The following is needed very urgently when no key-event is defined for
;;; toplevel-windows
(defmethod accept-focus-p ((contact toplevel-window))
  "Returns non-nil when CONTACT is willing to become the keyboard input focus"
  (declare (values boolean))
  (and (cluei::viewable-p contact)
       (cluei::sensitive-p contact)))

(defmethod key-press ((self toplevel-window) key)
  (case key
    (#\Control-\c (stop-event-loop (contact-display self)))))


;;;____________________________________________
;;;
;;; Handling Interclient messages from the WM
;;;____________________________________________

;;; 02/23/1992 (Hubertus)  TODO: 
;;;(defevent top-level-shell (:wm_save_yourself) saving-state)

(defevent top-level-shell (:wm_delete_window) check-terminating-application)

(defmethod check-terminating-application ((shell top-level-shell))
  (with-slots (cluei::children) shell
    (when cluei::children
      (check-terminating-application (first cluei::children)))))

(defmethod check-terminating-application ((self toplevel-window))
  ;; should return T, iff application has been terminated
  (when (confirm-terminating-application self)
    (let ((display (contact-display self)))
      (destroy (contact-parent self)) ;; destroy the shell    
      (stop-event-loop display)
      t)))
    
(defmethod confirm-terminating-application ((self toplevel-window))
  ;; to be filled by applications
  T)

;;; 
;;; Some Notes on Input Focus Management: 02/23/1992 (Hubertus)
;;; (also see X11 Interclient Communication Conventions)
;;; 
;;; There are four models of input handling:
;;;
;;; `No Input' - client never expects keyboard input.
;;; `Passive Input' - client expects keyboard input, but never explicitely 
;;;                   sets the input focus.
;;; `Locally Active Input' - client expects keyboard input and explicitely sets 
;;;                          the input focus, but does only so, when one of its 
;;;                          windows already has the focus.
;;; `Globally Active Input' - client expects keyboard input and explicitely sets 
;;;                          the input focus, even when it is in windows the client ;;;                          does not own.
;;;
;;; Currently, XIT uses the `Locally Active Input' model of input handling.
;;; (indicated by :wm-keyboard :on and wm_take_focus present in WM_PROTOCOLS).

(defun make-toplevel (&key (display *display*)
			   (shell-class 'top-level-shell)
			   (shell-title "XIT Toplevel")
			   (toplevel-class 'toplevel-window)
			   toplevel-init-list
			   shell-init-list)
  (declare (special *toplevel* *display* *shell*))
  (setq *shell* (apply #'make-contact shell-class
			      :parent display			
			      :width 10 :height 10 ; don't know if necessary
			      :wm-protocols-used '(:wm_take_focus
						   ;; :wm_save_yourself
						   :wm_delete_window) 
			      :wm-keyboard-input :on
			      :wm-title shell-title
			      :wm-icon-title shell-title
			      shell-init-list))
  (setq *toplevel* (apply #'make-contact toplevel-class
			  :parent *shell* toplevel-init-list))
  (update-state display)  ; this is needed for CLX windows created by toplevel hooks
  (call-open-toplevel-hooks *toplevel*)
  (update-state display)
  (process-all-events display)
  *toplevel*)


(defun setup-toplevel ()
  (query-x-server-host)
  (open-toplevel-display)
  (make-toplevel))
  

(defun make-and-loop-toplevel ()
  (make-toplevel)
  (toplevel-loop))

(defun start-event-loop (&optional (display *display*))
  (declare (special *display*))
  (format t "~%-- Starting Event Loop --~%")
  (catch 'quit-event-loop
    (loop (process-next-event display)))
  (format t "~%-- Stopping Event Loop --~%")
  display)

(defun start-eval-event-loop (&optional (display *display*))
  (declare (special *display*))
  (format t "~%-- Starting Event and Read Loop --~%~%<eval:> ")
  (catch 'quit-event-loop
    (loop (cond ((process-next-event display 1))
		((listen)	   
		 (format t "~{~S~%~}~&<eval:> "
			 (let ((result
				(multiple-value-list (eval (read)))))
			   (setq *** **)
			   (setq ** *)
			   (setq * (car result))
			   result))))))
  (format t "~%-- Stopping Event and Read Loop --~%")
  display)

(defun stop-event-loop (&optional (display *display*))
  (declare (special *display*))
  (ignoring-errors (ungrab-pointer display)
		   (throw 'quit-event-loop nil)))

(defun toplevel-loop (&optional (toplevel *toplevel*))
  (declare (special *toplevel*))
  (change-window-cursor toplevel "arrow")
  (start-event-loop (contact-display toplevel))
  (change-window-cursor toplevel "X_cursor")
  toplevel)

(defun eval-toplevel-loop (&optional (toplevel *toplevel*))
  (declare (special *toplevel*))
  (change-window-cursor toplevel "arrow")
  (start-eval-event-loop (contact-display toplevel))
  (change-window-cursor toplevel "X_cursor")
  toplevel)


(defmethod identify-window-internal ((self toplevel-window)
				     &key feedback? anchor test
				     mouse-documentation)
  "Follows the mouse optionally highlighting and/or drawing a rubberband to the current
   window until a mouse button is pressed. ANCHOR if given should be of type point."
  (declare (special *inversion-pixel*))
  (totop-window self)
  (let ((box-line-width 2)
	(rubber-line-width 1)
	(found-window nil)
	(stop-code nil)
	(stop-state nil)
	(old-found-window nil)
	(x1 nil) (y1 nil))
    (with-slots (display) self
      (using-gcontext (gc :drawable self :subwindow-mode :include-inferiors
			  :function BOOLE-XOR :foreground *inversion-pixel*
			  :line-width box-line-width)
	 (using-gcontext (rgc :drawable self :subwindow-mode :include-inferiors
			      :function BOOLE-XOR :foreground *inversion-pixel*
			      :line-width rubber-line-width)
	     (flet ((highlight-window (window)
		      (when (and (typep window 'basic-contact) (contact-parent window))
			;; (window-p window) 06/16/92 (Matthias) enclosing-region
			;; only defined for XIT windows
			;; 10/25/91 (Hubertus) changed for virtuals 
			(multiple-value-bind (x y w h) (enclosing-region window t t)
			  (draw-rectangle-inside (contact-parent window) gc
						 x y w h))))
		    (draw-rubber-band (x y)
		      (when anchor
			(draw-line self rgc (point-x anchor) (point-y anchor) x y))))
	       ;;Synchronization (e.g. button feedback)
	       (waiting-for-token-event (self))
	       ;;(process-all-events display)
	       (multiple-value-setq (x1 y1)
		 (query-pointer self))
	       (dragging-mouse (self :drag nil
				     :cursor "tcross"
				     :x1 x1 :y1 y1
				     :confine-to nil
				     :mouse-documentation mouse-documentation)
			       (:before (x1 y1)
					(draw-rubber-band x1 y1))
			       (:dragged (x1 y1 x y event-window)
					 (draw-rubber-band x1 y1)
					 (draw-rubber-band x y)
					 (setq found-window
					   (query-find-most-specific-window
					    test (contact-root event-window)))
					 (when (not (eq found-window old-found-window))
					   (when feedback?
					     (when old-found-window
					       (highlight-window old-found-window))
					     (when found-window
					       (highlight-window found-window)))
					   (setq old-found-window found-window)))
			       (:after (x y event-window code state)
				       (draw-rubber-band x y)
				       (setq found-window
					 (query-find-most-specific-window
					  test (contact-root event-window)))
				       (when feedback?
					 (when old-found-window
					   (highlight-window old-found-window)))
				       (setq stop-code code)
				       (setq stop-state state)
				       )
			       (:abort (x y event-window)
				       (draw-rubber-band x y)
				       (when feedback?
					 (when old-found-window
					   (highlight-window old-found-window)))
				       (setq found-window nil)))
	       (values found-window stop-code stop-state)))))))

(defmethod identify-window ((self toplevel-window)
			    &key (feedback? t) (anchor nil) test
			    (mouse-documentation
			     "Press button to identify window.")
			    (menu-button :button-3))
  "Follows the mouse optionally highlighting and/or drawing a rubberband to the current
   window until a mouse button is pressed. ANCHOR if given should be of type point."
  (multiple-value-bind (window code state)
      (identify-window-internal self
				:feedback? feedback?
				:anchor anchor
				:test test
				:mouse-documentation mouse-documentation)
    (declare (ignore state))
    (when window
      (if (and menu-button (eq (cluei::encode-button-number menu-button)
			       code))
	  (apply #'select-from
	   (do ((win window (contact-parent win))
		(last-win nil win)
		(menu-entries nil
			      (cons (cons (convert-to-string (contact-name win))
					  win)
				    menu-entries)))
	       ((or (null win) (eq last-win self))
		(cons '("ABORT") menu-entries))))
	window))))


(defmethod identify-window-with-mouse
  ((self toplevel-window) &optional (x-pos nil x-p) (y-pos nil y-p))
  (warn "identify-window-with-mouse is becoming obsolete. Please use identify-window.")
  (totop-window self)
  (let ((found-window nil))
    (cond ((and x-p y-p)
      (warp-pointer self x-pos y-pos)
      (identify-window self :feedback? nil :anchor (point x-pos y-pos)))
	  (t (identify-window self :feedback? nil)))))

(defmethod identify-window-property ((self basic-contact) property
							  &key window-test property-test
							  mouse-docu
							  mouse-documentation)
  
  (when mouse-docu (warn "identify-window-property: use keyword mouse-documentation instead of mouse-docu"))
  (let ((window (identify-window (toplevel-window self) :test window-test
				 :mouse-documentation
				 (or mouse-docu mouse-documentation))))
    (when (and window
	       (or (null property-test) (funcall property-test window)))
      (funcall property window))))


;;; 10/24/1991 (Hubertus)  
;;; Interactively specifying a region by rubberbanding.
;;;

(defmethod specify-region-with-mouse ((toplevel toplevel-window) &key
				      confine-to
				      resize-only?
				      (initial-region (region 0 0 0 0))
				      (minimum-width 0)
				      (minimum-height 0)
				      (maximum-width most-positive-fixnum)
				      (maximum-height most-positive-fixnum)
				      (line-style :solid)
				      (line-width 1)
				      (button-action :button-press))
  
  "Allows the user to specify a region with the mouse (relative to the 
   window specified by CONFINE-TO). After the mouse is grabbed 
   rubber-banding occurs until a mouse button is pressed.
   If the left button is pressed, the new region is returned. The user may 
   abort by pressing the middle button, returning NIL.
   To move the opposite corner of the region too, hold down the SHIFT key.
   The region is restricted to the window specified by CONFINE-TO (default
   TOPLEVEL). 
   If an INITIAL-REGION is specified, it is used to store the resulting values.
   MINIMUM-xxx and MAXIMUM-XXX specify constraints on the region size.
   If RESIZE-ONLY? is specified as non-NIL, the upper left corner of the region
   remains fixed."

  (declare (values (or null region))
	   (special *inversion-pixel*))
  (setq confine-to (or confine-to toplevel))
  (maxf (region-w initial-region) minimum-width)
  (minf (region-w initial-region) maximum-width)
  (maxf (region-h initial-region) minimum-height)
  (minf (region-h initial-region) maximum-height)
  (with-slots (display) toplevel
    (using-gcontext (gc :drawable confine-to
			:subwindow-mode :include-inferiors
			:function BOOLE-XOR
			:foreground *inversion-pixel*
			:line-width line-width
			:line-style line-style
			:dashes nil)
      (let ((width (region-w initial-region))
	    (height (region-h initial-region))
	    (x-pos (region-x initial-region))
	    (y-pos (region-y initial-region)))
	(warp-pointer confine-to (+ x-pos width) (+ y-pos height))
	(process-all-events display)
	(dragging-mouse
	 (confine-to :cursor "sizing"
		     :drag (eq button-action :button-release)
		     :abort-events '((:button-press :button-2 *))
		     :mouse-documentation
		     (format nil "Mouse-L: Position corner of rectangle;  ~
                                        Mouse-M: Abort~
                                        ~:[;   Hold down Shift to move opposite corner too.~;.~]"
			     resize-only?))
	 (:before () (draw-rectangle-inside confine-to gc x-pos y-pos width height))
	 (:dragged (state x y) (draw-rectangle-inside confine-to gc x-pos y-pos width height)
			(if (and (not resize-only?)
				   (member state
					   '#.`(,(make-state-mask :shift :button-1)
						,(make-state-mask :shift))
					   :test #'=))
			      ;; shift hold down, move opposite corner too

			      (setq x-pos (- x width)
				    y-pos (- y height))
			    (setq width (min maximum-width
					     (max minimum-width
						  (- x x-pos)))
				  height (min maximum-height
					      (max minimum-height
						   (- y y-pos)))))
			(draw-rectangle-inside confine-to gc x-pos y-pos width height))
	 (:abort () (draw-rectangle-inside confine-to gc x-pos y-pos width height)
		 nil)
	 (:after () (draw-rectangle-inside confine-to gc x-pos y-pos width height)
		 (setf (region-x initial-region) x-pos
		       (region-y initial-region) y-pos
		       (region-w initial-region) width
		       (region-h initial-region) height)
		 initial-region))))))

#|| Alt und (hin-)laenglich:
(defmethod specify-region-with-mouse ((toplevel toplevel-window) &key
				      confine-to
				      resize-only?
				      (initial-region (region 0 0 0 0))
				      (minimum-width 0)
				      (minimum-height 0)
				      (maximum-width most-positive-fixnum)
				      (maximum-height most-positive-fixnum)
				      (line-style :solid)
				      (line-width 1)
				      (button-action :button-press))
  
  "Allows the user to specify a region with the mouse (relative to the 
   window specified by CONFINE-TO). After the mouse is grabbed 
   rubber-banding occurs until a mouse button is pressed.
   If the left button is pressed, the new region is returned. The user may 
   abort by pressing the middle button, returning NIL.
   To move the opposite corner of the region too, hold down the SHIFT key.
   The region is restricted to the window specified by CONFINE-TO (default
   TOPLEVEL). 
   If an INITIAL-REGION is specified, it is used to store the resulting values.
   MINIMUM-xxx and MAXIMUM-XXX specify constraints on the region size.
   If RESIZE-ONLY? is specified as non-NIL, the upper left corner of the region
   remains fixed."

  (declare (values (or null region))
	   (special *inversion-pixel*))
  (setq confine-to (or confine-to toplevel))
  (maxf (region-w initial-region) minimum-width)
  (minf (region-w initial-region) maximum-width)
  (maxf (region-h initial-region) minimum-height)
  (minf (region-h initial-region) maximum-height)
  (with-slots (display) toplevel
    (using-gcontext (gc :drawable confine-to
			:subwindow-mode :include-inferiors
			:function BOOLE-XOR
			:foreground *inversion-pixel*
			:line-width line-width
			:line-style line-style
			:dashes nil)
      (let ((width (region-w initial-region))
	    (height (region-h initial-region))
	    (x-pos (region-x initial-region))
	    (y-pos (region-y initial-region)))
	(warp-pointer confine-to (+ x-pos width) (+ y-pos height))
	(process-all-events display)
	(if (eq :success
		(grab-pointer confine-to
			      '(:button-press :button-release :pointer-motion) 
			      :owner-p t
			      :confine-to confine-to
			      :sync-pointer-p t
			      :cursor (convert confine-to "sizing" 'cursor)
			      :time nil))
	    (with-mouse-documentation ("Mouse-L: Position corner of rectangle;  ~
                                        Mouse-M: Abort~
                                        ~:[;   Hold down Shift to move opposite corner too.~;.~]"
				       resize-only?)
	      (draw-rectangle-inside confine-to gc x-pos y-pos width height)
	      (catch 'abort
		(unwind-protect
		    (flet ((button-action (code)
			     (case code
			       (1 (draw-rectangle-inside confine-to gc x-pos y-pos width height)
				  T)
			       (2 ;; abort if middle button released
				(draw-rectangle-inside confine-to gc x-pos y-pos width height)
				(discard-current-event display)
				(throw 'abort nil))
			       (otherwise nil))))
		      (allow-events display :async-pointer)
		      (event-case (display :discard-p t :force-output-p t)
			(motion-notify (x y event-window state)
			(draw-rectangle-inside confine-to gc x-pos y-pos width height)
			(multiple-value-bind (confine-to-x confine-to-y)
			    (contact-translate event-window x y confine-to)
			  (if (and (not resize-only?)
				   (member state
					   '#.`(,(make-state-mask :shift :button-1)
						,(make-state-mask :shift))
					   :test #'=))
			      ;; shift hold down, move opposite corner too
			      (setq x-pos (- confine-to-x width)
				    y-pos (- confine-to-y height))
			    (setq width (min maximum-width
					     (max minimum-width
						  (- confine-to-x x-pos)))
				  height (min maximum-height
					      (max minimum-height
						   (- confine-to-y y-pos))))))
			(draw-rectangle-inside confine-to gc x-pos y-pos width height)
			nil) 
			(button-press (code)
			 (when (eq button-action :button-press)
			   (button-action code)))
			(button-release (code)
			 (when (eq button-action :button-release)
			   (button-action code)))
			))
		  (ungrab-pointer display))
		(setf (region-x initial-region) x-pos
		      (region-y initial-region) y-pos
		      (region-w initial-region) width
		      (region-h initial-region) height)
		initial-region))
	  (progn
	    (ungrab-pointer display)
	    nil))))))
||#




