wm.lisp

;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.61 2010-04-02 09:57:53 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
;;; Copyright (C) 2000
;;;          Julien BONINFANTE,
;;;          Aymeric LACORTE,
;;;          Jocelyn FRECHOT
;;; contact : hatchond@yahoo.fr
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;; usefull for having a quick and short garbage collection.
#+:cmu (setf extensions:*bytes-consed-between-gcs* 400000
	     extensions:*gc-verbose* nil)

(in-package :ECLIPSE-INTERNALS)

;;;; Decoration

(defclass decoration (base-widget)
  ((children :initarg :children :accessor decoration-children)
   (active-p :initform nil :accessor decoration-active-p)
   (wm-size-hints :initarg :wm-size-hints :reader decoration-wm-size-hints)
   (frame-style :initarg :frame-style :accessor decoration-frame-style)
   (old-frame-style :initform nil :initarg :old-frame-style)
   (application-gravity 
     :initarg :application-gravity
     :initform :north-west
     :accessor decoration-application-gravity))
  (:documentation "Top level widget for application that will have a set of 
   decoration (e.g: those for which window-not-decorable-p will return NIL)."))

(defun decoration-p (widget)
  (typep widget 'decoration))

(defun title-bar-horizontal-p (master)
  (eq :horizontal (style-title-bar-direction (decoration-frame-style master))))

(define-constant +decoration-event-mask+
    '(:substructure-redirect :substructure-notify
      :visibility-change :enter-window :owner-grab-button) :test #'equalp)

(defmethod get-child ((master decoration) label &key window)
  "Returns the child widget/window labeled `label' or nil if no such
  child exists. label is a keyword."
  (let ((widget (getf (decoration-children master) label)))
    (if (and widget window) (widget-window widget) widget)))

(defmethod decoration-wm-hints ((master decoration))
  "Returns as a multiple value: minw minh maxw maxh incw inch basew baseh."
  (with-slots (frame-style (wmsh wm-size-hints)) master
    (declare (type (vector integer 8) wmsh))
    (with-slots ((hm hmargin) (vm vmargin)) frame-style
      (values (+ hm (svref wmsh 0)) (+ vm (svref wmsh 1))
	      (+ hm (svref wmsh 2)) (+ vm (svref wmsh 3))
	      (svref wmsh 4) (svref wmsh 5)
	      (+ hm (svref wmsh 6)) (+ vm (svref wmsh 7))))))

(defmethod focus-widget ((master decoration) timestamp)
  (with-slots (window input-model) (get-child master :application)
    (set-focus input-model window timestamp)))

(defmethod focused-p ((master decoration))
  (focused-p (get-child master :application)))

(defmethod widget-position-fix-p ((master decoration))
  (widget-position-fix-p (get-child master :application)))

(defmethod shaded-p ((widget decoration))
  (with-slots (window) (get-child widget :application)
    (member :_net_wm_state_shaded (netwm:net-wm-state window))))

(defmethod shade ((master decoration))
  (with-slots (window frame-style) master
    (let* ((app-win (get-child master :application :window t))
	   (netwm-prop (netwm:net-wm-state app-win))
	   (gnome-prop (or (gnome:win-state app-win :result-type t) 0)))
      (setf gnome-prop (logand gnome-prop #x3DF)) ; supress :win_state_shaded
      (if (member :_net_wm_state_shaded netwm-prop)
	  (with-event-mask (window) 
	    ;; unshade.
	    (xlib:map-window app-win)
	    (xlib:map-window window)
	    (resize-from (get-child master :application))
	    (setf netwm-prop (remove :_net_wm_state_shaded netwm-prop))
	    (setf netwm-prop (remove :_net_wm_state_hidden netwm-prop))
	    (unless (stick-p app-win)
	      (setf (window-desktop-num app-win) (current-desk))))
	  (with-event-mask (window)	    
	    ;; shade.
	    (with-slots ((vm vmargin) (hm hmargin)) frame-style
	      (if (title-bar-horizontal-p master)
		  (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		  (unless (= 0 hm) (setf (xlib:drawable-width window) hm))))
	    (xlib:unmap-window app-win)
	    (pushnew :_net_wm_state_shaded netwm-prop)
	    (pushnew :_net_wm_state_hidden netwm-prop)
	    (incf gnome-prop 32)))	; add win_state_shaded
      (setf (netwm:net-wm-state app-win) netwm-prop
	    (gnome:win-state app-win) gnome-prop))))

(defmethod close-widget ((widget decoration))
  (close-widget (get-child widget :application)))

(defmethod put-on-top ((widget decoration))
  (put-on-top (get-child widget :application)))

(defmethod put-on-bottom ((widget decoration))
  (put-on-bottom (get-child widget :application)))

(defmethod maximize ((widget decoration) code &key (fill-p *maximize-fill*))
  (maximize (get-child widget :application) code :fill-p fill-p))

(defmethod (setf decoration-frame-style) :after (astyle (master decoration))
  (with-slots (window children wm-size-hints) master
    (with-slots (left-margin top-margin (hm hmargin) (vm vmargin)) astyle
      (with-event-mask (window)
	(let* ((application (getf children :application))
	       (icon (slot-value application 'icon))
	       (app-win (slot-value application 'window)))
	  (loop for (key val) on children by #'cddr
		unless (or (eq key :application) (eq key :icon))
		do (when (typep val 'edge)
		     (xlib:destroy-window (widget-window val)))
		   (remove-widget val))
	  (setf children (list :application application :icon icon)
		wm-size-hints (recompute-wm-normal-hints app-win hm vm))
	  (let ((width (+ (xlib:drawable-width app-win) hm))
		(height (+ (xlib:drawable-height app-win) vm)))
	    (setf (xlib:window-background window) (style-background astyle)
		  (window-position app-win) (values left-margin top-margin)
		  (drawable-sizes window) (values width height))
	    (make-frame-parts master)
	    (make-title-bar master (wm-name app-win))
	    (update-edges-geometry master)
	    (xlib:map-subwindows window))
	  (setf (application-frame-style application) astyle)
	  (cond ((shaded-p application)
		 (if (title-bar-horizontal-p master)
		     (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		     (unless (= 0 hm) (setf (xlib:drawable-width window) hm)))
		 (xlib:unmap-window app-win))
		((application-iconic-p application)
		 (xlib:unmap-window app-win))))))))

(defmethod dispatch-repaint ((master decoration) 
			     &key (focus (focused-p master)))
  (declare (optimize (speed 3) (safety 1)))
  (with-slots (parts-to-redraw-on-focus theme) (decoration-frame-style master)
    (declare (type theme theme))
    (mapc #'(lambda (k) (repaint (get-child master k) theme focus))
	  parts-to-redraw-on-focus)))

(defun recompute-wm-normal-hints (window hmargin vmargin)
  "Returns two value: a vector representing the wm-normal-hints property and
  the window gravity of the designed window. The wm-normal-hints property is
  recomputed in order to reflect the margin that a top level decoration widget
  (aka master) might introduce."
  (let ((hints (or (ignore-errors (wm-normal-hints window))
		   (xlib:make-wm-size-hints)))
	(max-ww (screen-width))
	(max-hh (screen-height)))
    (symbol-macrolet ((min-w (xlib:wm-size-hints-min-width hints))
		      (min-h (xlib:wm-size-hints-min-height hints))
		      (max-w (xlib:wm-size-hints-max-width hints))
		      (max-h (xlib:wm-size-hints-max-height hints))
		      (inc-w (xlib:wm-size-hints-width-inc hints))
		      (inc-h (xlib:wm-size-hints-height-inc hints))
		      (base-w (xlib:wm-size-hints-base-width hints))
		      (base-h (xlib:wm-size-hints-base-height hints))
		      (g (xlib:wm-size-hints-win-gravity hints)))
       (unless (eq g :static)
	 (decf max-ww hmargin)
	 (decf max-hh vmargin))
       (setf min-w (max (or (or min-w base-w) 1) 1)
	     min-h (max (or (or min-h base-h) 1) 1)
	     base-w (max (or (or base-w min-w) 1) 1)
	     base-h (max (or (or base-h min-h) 1) 1)
	     inc-w (or inc-w 1) 
	     inc-h (or inc-h 1))
      (setf max-ww (- max-ww (mod (- max-ww base-w) inc-w))
	    max-hh (- max-hh (mod (- max-hh base-h) inc-h)))
      (unless (and max-w (<= min-w max-w max-ww)) (setf max-w max-ww))
      (unless (and max-h (<= min-h max-h max-hh)) (setf max-h max-hh))
      (setf min-w (min min-w max-w)
	    min-h (min min-h max-h)
	    base-w (min base-w max-w)
	    base-h (min base-h max-h))
      (multiple-value-bind (w h) (drawable-sizes window)
	(unless (<= min-w w max-w) 
	  (setf (xlib:drawable-width window) (min (max min-w w) max-w)))
	(unless (<= min-h h max-h) 
	  (setf (xlib:drawable-height window) (min (max min-h h) max-h))))
      (values (vector min-w min-h max-w max-h inc-w inc-h base-w base-h) g))))

;;;; Decoration creation tools.

(defun make-menu-button (master parent-window)
  (with-slots (children frame-style) master
    (when (frame-item-exist-p frame-style :menu-button)
      (let ((pixmaps (frame-item-pixmaps frame-style :menu-button))
	    (horizontal-p (title-bar-horizontal-p master)))
	(declare (type pixmaps pixmaps))
	(multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0))
	  (multiple-value-bind (tw th) (drawable-sizes parent-window)
	    (setf (getf children :menu-button)
		  (create-button 'menu-button
		    :parent parent-window :master master
		    :background (aref pixmaps 0) 
		    :item (aref pixmaps 1)
		    :width width :height height
		    :event-mask '(:owner-grab-button . #.+push-button-mask+)
		    :y (if horizontal-p (ash (- th height) -1) (- th height))
		    :x (if horizontal-p 0 (ash (- tw width) -1))))))))))

(defun make-buttons-bar (master parent-window)
  (with-slots (children (astyle frame-style)) master
    (flet ((make-container (horizontal-p)
	     (xlib:create-window 
	        :parent parent-window
		:x 0 :y 0 :width 1 :height 1 
		:background :parent-relative 
		:gravity (if horizontal-p :north-east :north-west))))
      (loop initially (when (zerop (style-nb-buttons astyle)) (return))
	    with horizontal-p = (title-bar-horizontal-p master)
	    with container = (make-container horizontal-p)
	    and (x y width height) = '(0 0 0 0)
	    for type in '(iconify-button maximize-button close-button)
	    for child in '(:icon-b :maximize :close)
	    for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
	    for bkgrd = (aref pixmaps 0)
	    when (frame-item-exist-p astyle child)
	    do (multiple-value-setq (width height) (drawable-sizes bkgrd))
	       (setf (getf children child)
		     (create-button type
		       :parent container :master master
		       :background bkgrd :item (aref pixmaps 1)
		       :x x :y y :width width :height height
		       :event-mask +push-button-mask+))
	       (if horizontal-p (incf x width) (incf y height))
	    finally 
	      (multiple-value-bind (w h) (drawable-sizes parent-window)
		(if (zerop x) (incf x width) (incf y height))
		(setf (drawable-sizes container) (values x y)
		      (window-position container)
		      (if horizontal-p
			  (values (- w x) (ash (- h y) -1))
			  (values (ash (- w x) -1) 0)))
		(xlib:map-subwindows container)
		(return container))))))	    

(defun make-title-bar (master name)
  (with-slots (children frame-style) master
    (unless (eq :none (style-title-bar-position frame-style))
      (let* ((title-pos (style-title-bar-position frame-style))
	     (horizontal-p (case title-pos ((:top :bottom) t)))
	     (parent-widget (getf children title-pos))
	     (parent-window (widget-window parent-widget))
	     (button-container (make-buttons-bar master parent-window))
	     (menu-button (make-menu-button master parent-window))
	     (pixmaps (frame-item-pixmaps frame-style title-pos))
	     (bcw 0) (bch 0) (mbw 0) (mbh 0) (title))
	(declare (type pixmaps pixmaps))
	(when button-container
	  (multiple-value-setq (bcw bch) (drawable-sizes button-container)))
	(when menu-button
	  (multiple-value-setq (mbw mbh)
	    (drawable-sizes (widget-window menu-button))))
	(setf title
	      (create-button 'title-bar
		:parent parent-window :master master
		:width 1 :height 1
		:x (if horizontal-p mbw 0) :y (if horizontal-p 0 bch)
		:event-mask +push-button-mask+
		:background (aref pixmaps 0) :item name)
	      (slot-value title 'parent) parent-window
	      (getf children :title-bar) title
	      (xlib:window-background parent-window) :parent-relative
	      (xlib:window-event-mask parent-window) 0)
	(if horizontal-p 
	    (setf (slot-value title 'hmargin) (+ bcw mbw))
	    (setf (slot-value title 'vmargin) (+ bch mbh)))
	(xlib:map-subwindows parent-window)
	title))))

(defun edge-position (style edge-key width height)
  (with-slots (top-left-w top-left-h top-right-h bottom-left-w) style
    (multiple-value-bind (w h) (frame-item-sizes style edge-key)
      (case edge-key
	(:top (values top-left-w 0))
	(:right (values (- width w) top-right-h))
	(:bottom (values bottom-left-w (- height h)))
	(:left (values 0 top-left-h))
	(:top-left (values 0 0))
	(:top-right (values (- width w) 0))
	(:bottom-right (values (- width w) (- height h)))
	(:bottom-left (values 0 (- height h)))))))

(defvar *frame-parts*
  '(:right :left :top :bottom :top-left :top-right :bottom-left :bottom-right))

(defun make-frame-parts (master)
  (with-slots (children window (astyle frame-style)) master
    (multiple-value-bind (width height) (drawable-sizes window)
      (loop for child in *frame-parts*
	    for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
	    for hilighted = (aref pixmaps 1)
	    for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
	    when (frame-item-exist-p astyle child) do
	     (multiple-value-bind (x y)
		 (edge-position astyle child width height)
	       (multiple-value-bind (w h) (frame-item-sizes astyle child)
		 (setf (getf children child)
		       (create-button (intern (symbol-name child) :eclipse)
			 :parent window :master master
			 :background (aref pixmaps 0) :item hilighted
			 :event-mask event-mask
			 :x x :y y :width w :height h))))))))

;; Public.

(defun update-edges-geometry (master)
  (declare (optimize (speed 3) (safety 0)))
  (declare (inline update-edges-geometry))
  (macrolet
      ((update (edge size &rest frame-style-slots-size)
	 `(when ,edge
	    (setf (,(intern (format nil "DRAWABLE-~a" (symbol-name size)) :xlib)
		   (widget-window ,edge))
	          (with-slots (,@frame-style-slots-size) frame-style
		    (declare (type xlib:card16 ,@frame-style-slots-size))
		    (max 1 (- ,size ,@frame-style-slots-size)))))))
    (with-slots (frame-style window) master
      (multiple-value-bind (width height) (drawable-sizes window)
	(declare (type xlib:card16 width height))
	(update (get-child master :top) width top-left-w top-right-w)
	(update (get-child master :left) height top-left-h bottom-left-h)
	(update (get-child master :right) height top-right-h bottom-right-h)
	(update (get-child master :bottom) width bottom-left-w bottom-right-w)
	(update-title-bar-sizes (get-child master :title-bar))))))

(defun update-title-bar-sizes (title-bar)
  (declare (optimize (speed 3) (safety 0)))
  (when title-bar
    (with-slots (parent window (vm vmargin) (hm hmargin)) title-bar
      (declare (type xlib:card16 vm hm))
      (multiple-value-bind (width height) (drawable-sizes parent)
	(declare (type xlib:card16 width height))
	(setf (drawable-sizes window)
	      (values (max 1 (- width hm)) (max 1 (- height vm))))))))

(defun initial-coordinates (window frame-style)
  "Returns as multiple values the decoration initial coordinates."
  (let ((hint (ignore-errors (wm-normal-hints window))))
    (with-slots (top-margin left-margin vmargin hmargin) frame-style
      (flet ((default-coordinates ()
               (let* ((n (or (window-desktop-num window) 0))
                      (k (if (= +any-desktop+ n) 0 (* 4 n)))
                      (areas (netwm:net-workarea (xlib:drawable-root window)))
                      (ax (aref areas k)) (ay (aref areas (1+ k))))
                 (multiple-value-bind (x y) (window-position window)
                   (values (max ax (- x left-margin))
                           (max ay (- y top-margin)))))))
        (if (and hint (xlib:wm-size-hints-user-specified-position-p hint))
            (let ((x (xlib:wm-size-hints-x hint))
                  (y (xlib:wm-size-hints-y hint)))
              (if (and x y)
                  (case (xlib:wm-size-hints-win-gravity hint)
                    (:north-east (values (- x hmargin) y))
                    (:south-east (values (- x hmargin) (- y vmargin)))
                    (:south-west (values x (- y vmargin)))
                    (:static (values (- x left-margin) (- y top-margin)))
                    (t (values x y)))
                  (progn
                    (format t "user-specified-position-p t but x or y isn't.")
                    (default-coordinates))))
            (default-coordinates))))))

(defun make-decoration (app-window application &key theme)
  "Returns a newly initialized decoration to hold the given application."
  (unless theme (setf theme (root-decoration-theme *root*)))
  (let* ((netwm-states (ignore-errors (netwm:net-wm-state app-window)))
         (dstyle (find-decoration-frame-style theme app-window))
         (style dstyle)
         (fullscreen-p (member :_net_wm_state_fullscreen netwm-states)))
    (when fullscreen-p
      (setf style (theme-default-style (lookup-theme "no-decoration"))))
    (with-slots (hmargin vmargin left-margin top-margin background) style
      (multiple-value-bind (wm-sizes gravity)
          (recompute-wm-normal-hints app-window hmargin vmargin)
        (multiple-value-bind (width height) (drawable-sizes app-window)
          (multiple-value-bind (x y) (initial-coordinates app-window style)
            (let* ((window (xlib:create-window
                               :parent (xlib:drawable-root app-window)
                               :x x :y y
                               :width (+ width hmargin)
                               :height (+ height vmargin)
                               :background background
                               :event-mask +decoration-event-mask+
                               :do-not-propagate-mask
                               '(:button-press :button-release)))
                   (master (make-instance 'decoration
                               :window window
                               :old-frame-style dstyle :frame-style style
                               :children (list :application application)
                               :application-gravity gravity
                               :wm-size-hints wm-sizes)))
              (make-frame-parts master)
              (make-title-bar master (wm-name app-window))
              (update-edges-geometry master)
              (with-slots (icon (fgeometry full-geometry)) application
                (setf (getf (decoration-children master) :icon) icon
                      (slot-value icon 'master) master
                      (slot-value application 'master) master
                      (xlib:drawable-border-width app-window) 0)
                (when fullscreen-p
                  (multiple-value-bind (x y w h)
                      (fullscreen-sizes (xlib:window-display app-window))
                    (configure-window app-window :x x :y y :width w :height h))
                  (setf (geometry fgeometry) (values x y width height))))
              master)))))))

(defun decore-application (window application &key (map t) theme)
  "Decores an application and map the resulting decoration as indicated
  by the :map keyword argument. (default value is T).
  Returns the newly created decoration instance."
  (let* ((master (make-decoration window application :theme theme))
         (master-window (widget-window master))
         (left-margin (style-left-margin (decoration-frame-style master)))
         (top-margin (style-top-margin (decoration-frame-style master))))
    (with-event-mask (master-window)
      (xlib:map-subwindows master-window))
    (with-event-mask (master-window (when map +decoration-event-mask+))
      (xlib:reparent-window window master-window left-margin top-margin)
      (send-configuration-notify window))
    (setf (application-frame-style application) (decoration-frame-style master))
    ;; handle maximized states.
    (let* ((prop (netwm:net-wm-state window))
           (vert-p (member :_net_wm_state_maximized_vert prop))
           (horz-p (member :_net_wm_state_maximized_horz prop)))
      (when (or vert-p horz-p)
        (setf prop (delete :_net_wm_state_maximized_vert prop))
        (setf prop (delete :_net_wm_state_maximized_horz prop))
        (setf (netwm:net-wm-state window) prop)
        (maximize application (if (and horz-p vert-p) 1 (if horz-p 3 2)))))
    (when map (xlib:map-window window))
    master))

;;;; Focus management. According to ICCCM

(defgeneric set-focus (input-model window timestamp)
  (:documentation 
   "Set focus to the given window according to the input model.
   Input model can be :globally-active :locally-active :passive :no-input.
   For more information on the input-model sementic see ICCCM 4.1.7"))

(defmethod set-focus :around (input-model window timestamp)
  ;; If we have a valid timestamp then assign focus directly
  ;; otherwise set the net-active-window to provoke a property-notify event
  ;; on the root-property-holder. Then the property-notify event will handled
  ;; and will assign the focus with a valid timestamp.
  ;; It seems a bit complicated but this is the bettter way I found to not 
  ;; violate the ICCCM (section 4.1.7).
  (if (and timestamp (> timestamp 0))
      (and (next-method-p) (call-next-method))
      (with-slots ((ww window)) (root-property-holder *root*)
	(setf (netwm:net-active-window ww) window))))

(defmethod set-focus ((input-model (eql :globally-active)) window time)
  (send-wm-protocols-client-message window :wm_take_focus (or time 0)))

(defmethod set-focus ((input-model (eql :locally-active)) window time)
  (when (eql (xlib:window-map-state window) :viewable)
    (xlib:set-input-focus *display* window :pointer-root)
    (send-wm-protocols-client-message window :wm_take_focus (or time 0))))

(defmethod set-focus ((input-model (eql :passive)) window timestamp)
  (declare (ignorable timestamp))
  (when (eql (xlib:window-map-state window) :viewable)
    (xlib:set-input-focus *display* window :pointer-root)))

(defmethod set-focus ((input-model (eql :no-input)) window timestamp)
  (declare (ignorable window timestamp))
  (values))

(defmethod set-focus :after (input-model window timestamp)
  (declare (ignorable timestamp))
  (let ((states (netwm:net-wm-state window)))
    (when (member :_net_wm_state_demands_attention states)
      (setf (netwm:net-wm-state window)
            (remove :_net_wm_state_demands_attention states)))))

;; Next is methods for menu-3 who permit to manage any window :
;;  choose an action in the menu and click on a window
;;  to perform this action.

;; protocol for treating events
(defgeneric menu-3-process (event widget &rest rest))

(defmethod menu-3-process (event widget &rest rest)
  (declare (ignorable rest))
  (event-process event widget)
  nil)

(defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest)
  (declare (ignorable event w rest))
  (xlib:ungrab-pointer *display*)
  t)

(defmethod menu-3-process ((event button-release) (app application) &key key)
  (declare (ignorable event))
  (cond ((eql key :move) (finish-move app *verbose-move* *move-mode*)))
  (call-next-method))

(defmethod menu-3-process ((ev button-release) (dec decoration) &key key)
  (cond	((eql key :resize) (finish-resize dec *verbose-resize* *resize-mode*))
	((eql key :move) (finish-move dec *verbose-resize* *resize-mode*)))
  (call-next-method))

(defmethod menu-3-process ((ev motion-notify) (app application) &key key)
  (when (eql key :move)
    (activate-move-resize app *root* 'move-status *move-mode* *verbose-move*)
    (application-active-p app)))

(defmethod menu-3-process ((ev motion-notify) (master decoration) &key key)
  (when (or (eql key :resize) (eql key :move))
    (multiple-value-call #'activate-move-resize
      master *root*
      (cond ((eql key :resize)
	     (values 'resize-status *resize-mode* *verbose-resize*))
	    ((eql key :move)
	     (values 'move-status *move-mode* *verbose-move*))))
    (decoration-active-p master)))

(defmethod menu-3-process ((event enter-notify) (app application) &rest rest)
  (declare (ignorable event rest))
  (with-slots (window) (or (application-master app) app)
    (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
  nil)

(defmethod menu-3-process ((event enter-notify) (master decoration) &rest rest)
  (declare (ignorable event rest))
  (with-slots (window) master
    (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
  nil)

(defmethod menu-3-process ((event leave-notify) (app application) &rest rest)
  (declare (ignore event rest))
  (unless (application-master app) (xlib:ungrab-pointer *display*))
  nil)

(defmethod menu-3-process ((event leave-notify) (master decoration) &rest rest)
  (declare (ignore event master rest))
  (xlib:ungrab-pointer *display*)
  nil)

(defmethod menu-3-process ((ev button-press) (app application) &key key)
  (with-slots (master window) app
    (case key
      (:kill (kill-client-window window))
      (:close (close-widget app))
      (:resize (when master (initialize-resize master nil ev)))
      (:move (initialize-move (or master app) ev)))
    (when (member key '(:close :kill)) (xlib:ungrab-pointer *display*))))

(defmethod menu-3-process ((ev button-press) (master decoration) &key key)
  (menu-3-process ev (get-child master :application) :key key))

(defun define-menu-3 (action)
  (lambda ()
    (with-root-cursor (*cursor-2*)
      (destroy-substructure (slot-value *root* 'menu3))
      (loop for event = (get-next-event *display* :force-output-p t)
	    for widget = (lookup-widget (event-event-window event))
	    until (menu-3-process event widget :key action)))))

;;;; Misc.

(defun make-desktop-menu (root callback-maker &key realize)
  "Realize a root pop-up menu with as many entry as existing desktop. It attach
  to each entry a callback realized with the given `callback-maker' function.
  The callback-maker function should be a function of one argument of type
  integer that will be the index of the desktop entry. It may return a lambda
  or sub menu entries. If :realize is nil (the default value) it returns the
  menu entries otherwise a pop-up-menu object is return."
  (declare (type function callback-maker))
  (loop with root-window = (widget-window root)
	with names = (workspace-names root-window)
	for i from 0 below (number-of-virtual-screens root-window)
	for name = (or (pop names) (format nil "workspace ~D" i))
	collect (cons name (funcall callback-maker i)) into entries
	finally
	  (return (if realize (apply #'make-pop-up root entries) entries))))

(defun make-running-menu (root)
  "Realize the root pop-up menu that shows all applications ordered by desktop."
  (labels
      ((raise (window index)
	 (lambda ()
	   (case (first (wm-state window))
	     (1 (change-vscreen root :n index))
	     (3 (uniconify (slot-value (lookup-widget window) 'icon))))
	   (put-on-top (lookup-widget window))))
       (make-desktop-entries (i)
	 (loop for w in (screen-content i :iconify-p t)
	       for state = (= 1 (first (wm-state w)))
	       for name = (format nil "~:[[ ~A ]~;~A~]" state (wm-name w))
	       collect (cons name (raise w i)) into entries
	       finally
	        (return (or entries (lambda () (change-vscreen root :n i)))))))
    (make-desktop-menu root #'make-desktop-entries :realize t)))

(defun make-menu-button-menu (master)
  (let* ((app (get-child master :application))
	 (appw (widget-window app))
	 (net-wm-state (netwm:net-wm-state appw))
	 (data (make-array 1 :element-type 'xlib:card32))
	 (xc-msg (make-event :client-message :data data :type :_net_wm_desktop))
	 (shade-str (if (shaded-p app) "Un-shade" "Shade"))
	 (max-str (if (or (member :_net_wm_state_maximized_vert net-wm-state)
			  (member :_net_wm_state_maximized_horz net-wm-state))
		      "Un-maximize" "Maximize")))
    (declare (type (simple-array xlib:card32 (1)) data))
    (flet ((send-message (n)
	     (lambda ()
	       (setf (aref data 0) n)
	       (event-process xc-msg app))))
      (make-pop-up
          *root*
	  (cons "Send to" (make-desktop-menu *root* #'send-message))
	  (if (stick-p appw)
	      (cons "Un-pin" (send-message (current-desk)))
	      (cons "Pin   " (send-message +any-desktop+)))
	  (cons max-str (lambda () (maximize app 1)))
	  (cons shade-str (lambda () (shade master)))
	  (cons "Close  " (lambda () (close-widget app)))
	  (cons "Destroy" (lambda () (kill-client-window appw)))
	  (cons "Iconify" (lambda () (iconify app)))))))

(defun remove-window-from-client-lists (window root)
  "Removes a window from the client lists root properties."
  (with-slots ((rw window) client-list) root
    (remwinhash window client-list)
    (setf (netwm:net-client-list-stacking rw :mode :remove) window
	  (gnome:win-client-list rw :mode :remove) window
	  (netwm:net-client-list rw :mode :remove) window)))

(defun add-window-in-client-lists (window root)
  "Add a window in the client lists root properties."
  (with-slots ((rw window) client-list) root
    (let ((up2date (getwinhash window client-list)))
      (setf (getwinhash window client-list) window)
      (update-client-list-stacking root)
      (unless up2date
	(setf (netwm:net-client-list rw :mode :append) window))
      (if (member :win_hints_skip_winlist (gnome:win-hints window))
	  (setf (gnome:win-client-list rw :mode :remove) window)
	  (unless up2date
	    (setf (gnome:win-client-list rw :mode :append) window))))))

(defun update-client-list-stacking (root)
  "Recompute and set the root property net_client_list_stacking."
  (with-slots (window client-list) root
    (loop for win in (query-application-tree window)
	  when (getwinhash win client-list) collect win into wins
	  finally (setf (netwm:net-client-list-stacking window) wins))))

(defun update-lists (app state root)
  "Update root properties win_client_list, net_client_list(_stacking), 
  by adjoining or removing the given application depending of state."
  (with-slots ((appw window) iconic-p) app
    (case (if (and (= state 3) (not iconic-p)) 0 state)
      (0 (remove-window-from-client-lists appw root))
      (1 (add-window-in-client-lists appw root)))))

(defun window-not-decorable-p (window &optional type)
  "Returns T if a window `should' not be decorated. Typically, a splash screen,
  a desktop (e.g. nautilus) or a dock (e.g. gnome panels) will be assumed as
  non-decorable windows, as well as windows holding the motif_wm_hints with the
  flag `no decoration at all'."
  (let ((netwm-type (or type (netwm:net-wm-window-type window))))
    (or (eql (motif-wm-decoration window) :OFF)
	(member :_net_wm_window_type_splash netwm-type)
	(member :_net_wm_window_type_desktop netwm-type)
	(member :_net_wm_window_type_dock netwm-type))))

(defun procede-decoration (window)
  "Decore, if necessary, add/update properties, map or not, etc a window."
  (let* ((time (or (ignore-errors (net-wm-user-time window)) 1))
	 (rw (xlib:drawable-root window))
	 (scr-num (current-vscreen rw))
	 (application (create-application window nil))
	 (win-workspace (or (window-desktop-num window) +any-desktop+))
	 (stick-p (stick-p window)))
    (xlib:add-to-save-set window)
    (unless (or stick-p	(< -1 win-workspace (number-of-virtual-screens rw)))
      (setf win-workspace scr-num))
    (setf (window-desktop-num window) win-workspace)
    (cond ((not (or (= win-workspace scr-num) stick-p))
	   (with-event-mask (rw)
	     (setf (wm-state window) 1)
	     (xlib:unmap-window window)
	     (unless (window-not-decorable-p window)
	       (decore-application window application :map nil))
	     (update-lists application 1 *root*)))
	  ((window-not-decorable-p window (application-type application))
           (setf (netwm:net-frame-extents window) (values 0 0 0 0))
	   (setf (wm-state window) 1)
           (xlib:map-window window))
	  (t (decore-application window application :map t)))
    (with-slots (wants-focus-p input-model type) application
      (unless (member :_net_wm_window_type_desktop type)
	(unless (or (zerop time) (eq input-model :no-input))
	  (setf wants-focus-p *focus-new-mapped-window*)))
      (when (member :_net_wm_window_type_dock type)
	(update-workarea-property *root*)))))

;;;; The main loop.

(define-condition exit-eclipse (error)
  ((close-application-p
     :initform nil :initarg :close-application-p
     :type boolean :reader close-application-p)))

(defun eclipse-internal-loop ()
  (let ((close-display-p t)
        (exit 0))

    ;; Sets the root window pop-up menu
    (when *menu-1-exit-p*
      (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '())))
    (with-slots (menu1 menu3) *root*
      (setf menu1 (apply #'make-pop-up *root* *menu-1-items*)
	    menu3 (make-pop-up *root*
			       (cons "Move" (define-menu-3 :move))
			       (cons "Resize" (define-menu-3 :resize))
			       (cons "Close" (define-menu-3 :close))
			       (cons "Kill" (define-menu-3 :kill)))))

    ;; Dress windows already displayed at start time.
    (flet ((ignorable-window-p (window)
	     (let* ((wmh (xlib:get-property window :WM_HINTS))
		    (initial-state (and wmh (logbitp 1 (car wmh)) (third wmh)))
		    (wm-state (car (wm-state window))))
	       (or
		(eql (xlib:window-override-redirect window) :ON)
		(when (or (eq initial-state 0) (eq wm-state 0))
		  (xlib:unmap-window window)
		  t)
		(and (not wm-state)
		     (eq (xlib:window-map-state window) :unmapped))))))

      (xlib:with-server-grabbed (*display*)
	(mapc (lambda (w)
                (unless (ignore-errors (ignorable-window-p w))
		  (procede-decoration w)))
	      (xlib:query-tree *root-window*))))
    ;; Main loop
    (loop
       (handler-case
           (let ((event (get-next-event *display* :discard-p t :timeout 2)))
             (when event
               (with-slots (event-window) event
                 (event-process event (lookup-widget event-window)))
               (xlib:display-finish-output *display*))
             (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
             (with-slots (sm-conn) *root*
               (when sm-conn (handle-session-manager-request sm-conn *root*)))
             (case exit
               (1 (loop for val being each hash-value in *widget-table*
                        when (application-p val) 
                        if close-display-p do (close-widget val)
                        else do (undecore-application val))
		   (setf exit 2))
               (2 (when (root-sm-conn *root*)
                    (close-sm-connection *root* :exit-p nil))
                  (xlib:display-finish-output *display*)
                  (setf (xlib:window-event-mask *root-window*) 0)
                  (let ((win (netwm:net-supporting-wm-check *root-window*)))
                    (xlib:destroy-window win))
                  (xlib:display-finish-output *display*)
                  (return))))
         (exit-eclipse (c)
           (setf close-display-p (close-application-p c))
           (setf exit 1))
         (end-of-file (c) (error c))
         (already-handled-xerror () nil)
         (error (c) (handle-error-condition c))))
    (format t "~%Main loop exited~%")))