Commit 4b4de85e authored by Iban Hatchondo's avatar Iban Hatchondo
Browse files

Maximize fill implemented:

 - new file rectangles.lisp.
 - maximize-window modified to use the maximize-fill operaion.
 - new user configuration option: *maximize-fill*

We now support the netwm-strut{-partial}, and don't overlap panels that should not be overlapped (gnome panels for exemple)

package.lisp, system.lisp updated.
parent 83a801f9
;;; -*- Mode: Lisp; Package: User -*-
;;; $Id: package.lisp,v 1.9 2003/10/06 17:57:26 ihatchondo Exp $
;;; $Id: package.lisp,v 1.10 2003/10/09 11:40:38 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -235,15 +235,8 @@
"CLOSE-WIDGET" ;generic function
"DECORATION-ACTIVE-P" ;generic function
"DECORATION-APPLICATION-GRAVITY" ;generic function
"DECORATION-BASE-HEIGHT" ;generic function
"DECORATION-BASE-WIDTH" ;generic function
"DECORATION-CHILDREN" ;generic function
"DECORATION-FRAME-STYLE" ;generic function
"DECORATION-INC-SIZES" ;generic function
"DECORATION-MAX-HEIGHT" ;generic function
"DECORATION-MAX-WIDTH" ;generic function
"DECORATION-MIN-HEIGHT" ;generic function
"DECORATION-MIN-WIDTH" ;generic function
"DECORATION-PRECEDENT-TIME" ;generic function
"DECORATION-WM-HINTS" ;generic function
"DECORATION-WM-SIZE-HINTS" ;generic function
......@@ -352,16 +345,21 @@
;; user custom.
"*CHANGE-DESKTOP-MESSAGE-ACTIVE-P*" ;variable
"*CLOSE-DISPLAY-P*" ;variable
"*CYCLE-ICONS-P*" ;variable
"*DOUBLE-CLICK-SPEED*" ;variable
"*FOCUS-TYPE*" ;variable
"*FOCUS-NEW-MAPPED-WINDOW*" ;variable
"*FOCUS-WHEN-WINDOW-CYCLE*" ;variable
"*ICON-BOX-SORT-FUNCTION*" ;variable
"*ICON-HINTS*" ;variable
"*MAXIMIZE-FILL*" ;variable
"*MENU-1-ITEMS*" ;variable
"*MOVE-MODE*" ;variable
"*RESIZE-MODE*" ;variable
"*SCREEN-EDGE-RESISTANT-P*" ;variable
"*STANDARD-WINDOW-EDGE-RESISTANT-P*" ;variable
"*VERBOSE-MOVE*" ;variable
"*VERBOSE-RESIZE*" ;variable
"*VERBOSE-WINDOW-CYCLING*" ;variable
"*WARP-POINTER-WHEN-CYCLE*" ;variable
))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id$
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2003 Iban HATCHONDO
;;; 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.
(in-package :ECLIPSE-INTERNALS)
(defstruct rectangle
(ulx 0 :type (signed-byte 16))
(uly 0 :type (signed-byte 16))
(lrx 0 :type (signed-byte 16))
(lry 0 :type (signed-byte 16)))
(declaim (inline rectangle-coordinates))
(defun rectangle-coordinates (r)
(values (rectangle-ulx r) (rectangle-uly r)
(rectangle-lrx r) (rectangle-lry r)))
(declaim (inline rectangle-surface))
(defun rectangle-surface (rectangle)
"Compute the area of a rectangle. The value NIL represents an empty rectangle"
(if (null rectangle) 0
(multiple-value-bind (ulx uly lrx lry) (rectangle-coordinates rectangle)
(* (- lrx ulx) (- lry uly)))))
(declaim (inline rectangle-width))
(defun rectangle-width (rect)
"Return the width of a rectangle."
(if (null rect) 0 (- (rectangle-lrx rect) (rectangle-ulx rect))))
(declaim (inline rectangle-height))
(defun rectangle-height (rect)
"Return the height of a rectangle."
(if (null rect) 0 (- (rectangle-lry rect) (rectangle-uly rect))))
(defun rectangle-surface< (rectangle1 rectangle2)
(< (rectangle-surface rectangle1) (rectangle-surface rectangle2)))
(defun rectangle-surface>= (rectangle1 rectangle2)
(>= (rectangle-surface rectangle1) (rectangle-surface rectangle2)))
(defun rectangle-surface= (rectangle1 rectangle2)
(= (rectangle-surface rectangle1) (rectangle-surface rectangle2)))
(defun rectangle-width>= (rect1 rect2)
(>= (rectangle-width rect1) (rectangle-width rect2)))
(defun rectangle-height>= (rect1 rect2)
(>= (rectangle-height rect1) (rectangle-height rect2)))
(defun sub-rectangles (outside inside)
"Return the four (if exists) sub rectangles defined by the internal
rectangle in the outside one. The returned list will be sort ascending
order."
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (ulx1 uly1 lrx1 lry1) (rectangle-coordinates outside)
(declare (type (signed-byte 16) ulx1 uly1 lrx1 lry1))
(multiple-value-bind (ulx2 uly2 lrx2 lry2) (rectangle-coordinates inside)
(declare (type (signed-byte 16) ulx2 uly2 lrx2 lry2))
(let ((seq (list)))
(when (< uly1 uly2) ; defines the north sub rectangle.
(push (make-rectangle :ulx ulx1 :uly uly1 :lrx lrx1 :lry uly2) seq))
(when (< ulx1 ulx2) ; defines the west sub rectangle.
(push (make-rectangle :ulx ulx1 :uly uly1 :lrx ulx2 :lry lry1) seq))
(when (< lry2 lry1) ; defines the south sub rectangle.
(push (make-rectangle :ulx ulx1 :uly lry2 :lrx lrx1 :lry lry1) seq))
(when (< lrx2 lrx1) ; defines the east sub rectangle.
(push (make-rectangle :ulx lrx2 :uly uly1 :lrx lrx1 :lry lry1) seq))
(stable-sort seq #'rectangle-surface>=)))))
(defun overlap-p (rect1 rect2)
"Return true if rectangle1 intersects rectangle2."
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (ulx1 uly1 lrx1 lry1) (rectangle-coordinates rect1)
(declare (type (signed-byte 16) ulx1 uly1 lrx1 lry1))
(multiple-value-bind (ulx2 uly2 lrx2 lry2) (rectangle-coordinates rect2)
(declare (type (signed-byte 16) ulx2 uly2 lrx2 lry2))
(and (< ulx1 lrx2) (< ulx2 lrx1) (< uly1 lry2) (< uly2 lry1)))))
(defun include-p (rect1 rect2)
"Return true if rectangle1 is included in rectangle2."
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (ulx1 uly1 lrx1 lry1) (rectangle-coordinates rect1)
(declare (type (signed-byte 16) ulx1 uly1 lrx1 lry1))
(multiple-value-bind (ulx2 uly2 lrx2 lry2) (rectangle-coordinates rect2)
(declare (type (signed-byte 16) ulx2 uly2 lrx2 lry2))
(and (<= ulx1 ulx2) (<= uly1 uly2) (<= lrx2 lrx1) (<= lry2 lry1)))))
(defun rectangle-intersection (rect1 rect2)
"Return the intersection of rect1 and rect2 or nil of they do not overlap."
(declare (optimize (speed 3) (safety 0)))
(multiple-value-bind (ulx1 uly1 lrx1 lry1) (rectangle-coordinates rect1)
(declare (type (signed-byte 16) ulx1 uly1 lrx1 lry1))
(multiple-value-bind (ulx2 uly2 lrx2 lry2) (rectangle-coordinates rect2)
(declare (type (signed-byte 16) ulx2 uly2 lrx2 lry2))
(when (and (< ulx1 lrx2) (< ulx2 lrx1) (< uly1 lry2) (< uly2 lry1))
(make-rectangle :ulx (max ulx1 ulx2) :uly (max uly1 uly2)
:lrx (min lrx1 lrx2) :lry (min lry1 lry2))))))
(defun rectangle-intersection* (rectangle rectangles)
"Return all the intersections of rectangle with each rectangle of the list."
(loop for rect in rectangles when (rectangle-intersection rectangle rect)
collect it))
(defun find-empty-rectangles (space obstacles order)
"Return all the largest empty rectangles of space according
to the obstacles list sorted according order."
(setf obstacles (stable-sort
(rectangle-intersection* space obstacles)
#'rectangle-surface>=))
(unless obstacles (return-from find-empty-rectangles (list space)))
(loop for ss in (sub-rectangles space (car obstacles))
nconc (find-empty-rectangles ss (cdr obstacles) order) into result
finally (return (stable-sort result order))))
(defun window->rectangle (window)
"Return the rectangle that represent this window."
(multiple-value-bind (x y w h) (window-geometry window)
(make-rectangle :ulx x :uly y :lrx (+ x w) :lry (+ y h))))
(defun compute-screen-rectangles (application)
"Get screen content according to desktop number and filter all windows that
are overlaped by the given one. Return a list of rectangles that represent
all the founded windows."
(with-slots (window master) application
(multiple-value-bind (xx yy ww hh)
(window-geometry (if master (widget-window master) window))
(flet ((predicate (win n icon taskbar desktop dock)
(cond
((xlib:window-equal window win) nil)
((window-belongs-to-vscreen-p win n icon taskbar desktop dock)
(multiple-value-bind (x y w h)
(with-slots ((m master)) (lookup-widget win)
(window-geometry (if m (widget-window m) win)))
(not (and (< xx (+ x w)) (< x (+ xx ww))
(< yy (+ y h)) (< y (+ yy hh))))))
(t (window-panel-p win n icon)))))
(mapcar
(lambda (win)
(with-slots ((m master)) (lookup-widget win)
(window->rectangle (if m (widget-window m) win))))
(screen-content (window-desktop-num window)
:predicate #'predicate :skip-taskbar nil))))))
(defun find-all-panel-rectangles (window &key (predicate #'window-panel-p))
"Get all panel type window on this virtual desktop. Return a list of
rectangles representing all the founded windows."
(mapcar
(lambda (win)
(multiple-value-bind (l r to b lsy ley rsy rey tsx tex bsx bex)
(netwm:net-wm-strut-partial win)
(multiple-value-bind (w h) (drawable-sizes (xlib:drawable-root win))
(unless l
(multiple-value-setq (l r to b) (netwm:net-wm-strut win))
(multiple-value-setq (lsy ley rsy rey tsx tex bsx bex)
(values 0 h 0 h 0 w 0 w))
(unless (and l r to b)
(setf (values l r to b) (values 0 0 0 0))))
(cond
((/= 0 l) (make-rectangle :ulx 0 :uly lsy :lrx l :lry ley))
((/= 0 r) (make-rectangle :ulx (- w r) :uly rsy :lrx w :lry rey))
((/= 0 to) (make-rectangle :ulx tsx :uly 0 :lrx tex :lry to))
((/= 0 b) (make-rectangle :ulx bsx :uly (- h b) :lrx bex :lry h))
(t (window->rectangle win))))))
(screen-content (window-desktop-num window) :predicate predicate)))
(defun window-panel-p (window scr-num iconify-p &rest options)
"Return true if window is a panel (in the sens of Gnome/KDE panel)."
(declare (ignorable options))
(when (lookup-widget window)
(let ((n (or (window-desktop-num window) -1))
(wm-state (car (wm-state window))))
(and (or (= n scr-num) (= n +any-desktop+))
(or (eq wm-state 1) (and iconify-p (eq wm-state 3)))
(or (multiple-value-bind (resource class)
(xlib:get-wm-class window)
(declare (ignore resource))
(string= class "Panel"))
(member :_net_wm_window_type_dock
(netwm:net-wm-window-type window)))))))
(defun find-largest-empty-area
(application &key area-include-me-p (panels-only-p t) direction)
"Return as a multiple values the coordinates of the largest empty area on
the desktop of the application.
- If :area-include-me-p is T then the searched area WILL contain the
application (default is NIL).
- If :panels-only-p is T (the default), the research will not includes any
other windows of the desktop. Otherwise all mapped windows on the desktop
will be taken in account.
- :direction (or :vertical :horizontal :both) to indicate wat kind of
region the search should be looking for."
(with-slots (window (m master)) application
(multiple-value-bind (w h) (drawable-sizes (xlib:drawable-root window))
(let ((app-rect (window->rectangle (if m (widget-window m) window)))
(rectangles (find-empty-rectangles
(make-rectangle :lrx w :lry h)
(if panels-only-p
(find-all-panel-rectangles window)
(compute-screen-rectangles application))
(case direction
(:horizontal #'rectangle-width>=)
(:vertical #'rectangle-height>=)
(t #'rectangle-surface>=)))))
;; clip the application window rectangle to fit in the root one.
(when (< (rectangle-ulx app-rect) 0) (setf (rectangle-ulx app-rect) 0))
(when (< (rectangle-uly app-rect) 0) (setf (rectangle-uly app-rect) 0))
(when (> (rectangle-lrx app-rect) w) (setf (rectangle-lrx app-rect) w))
(when (> (rectangle-lry app-rect) h) (setf (rectangle-lry app-rect) h))
;; returns the appropriated area.
(rectangle-coordinates
(if area-include-me-p
(loop for r in rectangles until (include-p r app-rect)
finally (return r))
(car rectangles)))))))
;;; -*- Mode: Lisp; Package: User -*-
;;; $Id: system.lisp,v 1.6 2003/08/28 14:50:35 hatchond Exp $
;;; $Id: system.lisp,v 1.7 2003/11/10 10:02:53 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -72,6 +72,7 @@
"gestures"
"widgets"
"virtual-screen"
"rectangles"
"wm"
"input"
"move-resize"
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.22 2003/10/09 11:37:08 ihatchondo Exp $
;;; $Id: wm.lisp,v 1.23 2003/11/19 10:29:08 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -53,34 +53,14 @@
(let ((widget (getf (decoration-children master) label)))
(if (and widget window) (widget-window widget) widget)))
(defmethod decoration-min-width ((master decoration))
(with-slots (hmargin) (decoration-frame-style master)
(+ hmargin (aref (slot-value master 'wm-size-hints) 0))))
(defmethod decoration-min-height ((master decoration))
(with-slots (vmargin) (decoration-frame-style master)
(+ vmargin (aref (slot-value master 'wm-size-hints) 1))))
(defmethod decoration-max-width ((master decoration))
(with-slots (hmargin) (decoration-frame-style master)
(+ hmargin (aref (slot-value master 'wm-size-hints) 2))))
(defmethod decoration-max-height ((master decoration))
(with-slots (vmargin) (decoration-frame-style master)
(+ vmargin (aref (slot-value master 'wm-size-hints) 3))))
(defmethod decoration-base-width ((master decoration))
(with-slots (hmargin) (decoration-frame-style master)
(+ hmargin (aref (slot-value master 'wm-size-hints) 6))))
(defmethod decoration-base-height ((master decoration))
(with-slots (vmargin) (decoration-frame-style master)
(+ vmargin (aref (slot-value master 'wm-size-hints) 7))))
(defmethod decoration-inc-sizes ((master decoration))
(with-slots (wm-size-hints) master
(values (aref wm-size-hints 4) (aref wm-size-hints 5))))
(defmethod decoration-wm-hints ((master decoration))
(with-slots (wm-size-hints) master
(values (decoration-min-width master) (decoration-min-height master)
(decoration-max-width master) (decoration-max-height master)
(aref wm-size-hints 4) (aref wm-size-hints 5)
(decoration-base-width master) (decoration-base-height master))))
"return as a multiple value: minw minh maxw maxh incw inch basew baseh."
(with-slots (frame-style (wmsh wm-size-hints)) master
(with-slots ((hm hmargin) (vm vmargin)) frame-style
(values (+ hm (aref wmsh 0)) (+ vm (aref wmsh 1))
(+ hm (aref wmsh 2)) (+ vm (aref wmsh 3))
(aref wmsh 4) (aref wmsh 5)
(+ hm (aref wmsh 6)) (+ vm (aref wmsh 7))))))
(defmethod focused-p ((master decoration))
(focused-p (get-child master :application)))
......@@ -431,57 +411,80 @@
(when map (xlib:map-window window))
master))
(defun maximize-window (application button-code)
(defun find-max-geometry (application direction fill-p &key x y w h)
(multiple-value-bind (ulx uly lrx lry)
(find-largest-empty-area
application
:area-include-me-p (or (/= 1 direction) fill-p)
:panels-only-p (not fill-p)
:direction (case direction (2 :vertical) (3 :horizontal) (t :both)))
(with-slots (window master) application
(with-slots ((hm hmargin) (vm vmargin))
(if master (decoration-frame-style master)
(theme-default-style (lookup-theme "no-decoration")))
(symbol-macrolet ((minw (aref wmsh 0)) (minh (aref wmsh 1))
(maxw (aref wmsh 2)) (maxh (aref wmsh 3))
(incw (aref wmsh 4)) (inch (aref wmsh 5))
(basew (aref wmsh 6)) (baseh (aref wmsh 7)))
(let* ((wmsh (recompute-wm-normal-hints window hm vm))
(ww (or w (check-size (- lrx ulx hm) basew incw minw maxw)))
(hh (or h (check-size (- lry uly vm) baseh inch minh maxh))))
(when (> (+ ww hm) (- lrx ulx)) (decf ww incw))
(when (> (+ hh vm) (- lry uly)) (decf hh inch))
(make-geometry :w ww :h hh :x (or x ulx) :y (or y uly))))))))
(defun compute-max-geometry
(application x y w h direction fill-p vert-p horz-p)
(symbol-macrolet
((ix (geometry-x initial-geometry)) (iy (geometry-y initial-geometry))
(iw (geometry-w initial-geometry)) (ih (geometry-h initial-geometry)))
(with-slots (initial-geometry) application
(case direction
;; Unmaximize or Maximize in both directions
(1 (if (or horz-p vert-p)
(copy-geometry initial-geometry)
(find-max-geometry application direction fill-p)))
;; Unmaximize or Maximize Vertically
(2 (if vert-p
(make-geometry :x x :y iy :w w :h ih)
(find-max-geometry application direction fill-p :x x :w w)))
;; Unmaximize or Maximize Horizontally
(3 (if horz-p
(make-geometry :x ix :y y :w iw :h h)
(find-max-geometry application direction fill-p :y y :h h)))))))
(defun maximize-window (application code &key (fill-p *maximize-fill*))
(with-slots ((app-window window) initial-geometry full-geometry master)
application
(when (shaded-p master) (shade master))
(let* ((new-sizes)
(let* ((new-g)
(m-window (if master (widget-window master) app-window))
(prop (netwm:net-wm-state app-window))
(fullscreen-p (member :_net_wm_state_fullscreen prop))
(vert-p (member :_net_wm_state_maximized_vert prop))
(horz-p (member :_net_wm_state_maximized_horz prop))
(wm-size-hints (if master
(slot-value master 'wm-size-hints)
(recompute-wm-normal-hints app-window 0 0))))
(vert-p (car (member :_net_wm_state_maximized_vert prop)))
(horz-p (car (member :_net_wm_state_maximized_horz prop))))
(multiple-value-bind (x y) (window-position m-window)
(multiple-value-bind (w h) (drawable-sizes app-window)
(unless (or horz-p vert-p)
(if fullscreen-p
(setf initial-geometry (copy-geometry full-geometry))
(setf (geometry initial-geometry) (values x y w h))))
(symbol-macrolet ((ix (geometry-x initial-geometry))
(iy (geometry-y initial-geometry))
(iw (geometry-w initial-geometry))
(ih (geometry-h initial-geometry))
(maxw (aref wm-size-hints 2))
(maxh (aref wm-size-hints 3)))
(case button-code
;; Unmaximize or Maximize in both directions
(1 (if (or horz-p vert-p)
(setf new-sizes (copy-geometry initial-geometry)
horz-p t vert-p t)
(setf new-sizes (make-geometry :w maxw :h maxh))))
;; Unmaximize or Maximize Vertically
(2 (if vert-p
(setf new-sizes (make-geometry :x x :y iy :w w :h ih))
(setf new-sizes (make-geometry :x x :w w :h maxh))))
;; Unmaximize or Maximize Horizontally
(3 (if horz-p
(setf new-sizes (make-geometry :x ix :y y :w iw :h h))
(setf new-sizes (make-geometry :y y :w maxw :h h))))))))
(unless (= 3 button-code)
(setf new-g (compute-max-geometry
application x y w h code fill-p vert-p horz-p))))
(when (and (= 1 code) (or horz-p vert-p))
(setf (values horz-p vert-p) (values t t)))
(unless (= 3 code)
(if vert-p
(setf prop (delete :_net_wm_state_maximized_vert prop))
(pushnew :_net_wm_state_maximized_vert prop)))
(unless (= 2 button-code)
(unless (= 2 code)
(if horz-p
(setf prop (delete :_net_wm_state_maximized_horz prop))
(pushnew :_net_wm_state_maximized_horz prop)))
(if fullscreen-p
(setf full-geometry new-sizes)
(setf (window-position m-window) (geometry-coordinates new-sizes)
(drawable-sizes app-window) (geometry-sizes new-sizes)))
(setf full-geometry new-g)
(setf (window-position m-window) (geometry-coordinates new-g)
(drawable-sizes app-window) (geometry-sizes new-g)))
(setf (netwm:net-wm-state app-window) prop))))
;;;; Focus management. According to ICCCM
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment