Commit afc32f42 authored by hatchond's avatar hatchond
Browse files

applied Christian Lynbech patch for icon managment:

"Here is a diff that adds what I think is improved icon handling. It
provides an icon box, ie. a configurable place where icons are
stacked. As part of this change, I have changed the default location
of icons from (750,50) to (0,0). If the icon box overflows, icons will
be created ayt (0,0). I have also decreased the default height from 60
to 20 to minimize the space waste (if the application supplies an
icon, it will of course take precedence).

The patch allso adds different kinds of sorting options. Icons can be
sorted by creation time (I have added a new slot in the `icon' class)
or name or class (or whatever else you can think of).

Unrelated to the icon box thing, the patch also contains a set of
application inspection function (see the end of "misc.lisp"), A
disabling of the expression that removes the "Exit" entry in the root
menu so that you can close Eclipse down and finally a new option,
*close-display-p*, that regulates whether exiting Eclipse also kills
the entire X session (if *close-display-p* is nil, Eclipse will just

It still needs a few things, such as the possibility of disabling the
icon box and other fill orders than :top-right (ie. filling from the
top right corner of the box).

Let me know what you think."

plus small corrections from me (for fullscreen-mode, but it still cause problems).
parent 6f6e3b8c
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: global.lisp,v 1.5 2003/03/19 10:54:33 hatchond Exp $
;;; $Id: global.lisp,v 1.6 2003/04/07 13:35:32 hatchond Exp $
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
......@@ -59,7 +59,8 @@
(defvar *gcontext* nil)
(defvar *widget-table* (make-hash-table))
;; Default value of all the "customisable" environement variables
;; Default value of all the "customisable" environment variables
(defparameter *close-display-p* t)
(defparameter *menu-1-items* nil)
(defparameter *nb-vscreen* 4)
(defparameter *change-desktop-message-active-p* t)
......@@ -74,6 +75,17 @@
(defparameter *font-name*
(defparameter *icon-hints* nil)
(defparameter *icon-box* '#(-75 5 -5 -5)
"top left and bottom right corner coordinates of the icon box area")
(defparameter *icon-box-sep* 2)
(defparameter *icon-box-fill* :top-right
"icon box fill strategy, one of :{top,bottom}-{left,right}")
(defparameter *icon-box-sort-function* nil
"Function determining icon order within the box.
NIL corresponds to the default which is to sort on order of creation
\(aka `icon-sort-creation-order'\).")
(defsetf font-name () (name)
`(setf *font-name* ,name
(xlib:gcontext-font *gcontext*) (xlib:open-font *display* ,name)))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.4 2003/03/21 09:54:47 hatchond Exp $
;;; $Id: input.lisp,v 1.5 2003/04/07 13:35:32 hatchond Exp $
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -299,6 +299,14 @@
(update-lists app (car (wm-state window)) *root*)))))
(defun fullscreenable (application)
(with-slots (window) application
(let ((hint (ignore-errors (xlib:wm-normal-hints window))))
(symbol-macrolet ((max-w (xlib:wm-size-hints-max-width hint))
(max-h (xlib:wm-size-hints-max-height hint)))
(and (if max-w (= max-w (screen-width)) t)
(if max-h (= max-h (screen-height)) t))))))
(defmethod event-process ((event client-message) (application application))
(with-slots (data type) event
(with-slots (master window) application
......@@ -341,7 +349,8 @@
(if (= action 0) (uniconify application) (iconify application)))
(when (or (eql prop1 :_net_wm_state_fullscreen)
(eql prop2 :_net_wm_state_fullscreen))
(setf (full-screen-mode application) (if (= action 0) :off :on)))
(when (fullscreenable application)
(setf (full-screen-mode application) (if (= action 0) :off :on))))
(when master
(when (or (eql prop1 :_net_wm_state_maximized_vert)
(eql prop2 :_net_wm_state_maximized_vert))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: misc.lisp,v 1.3 2003/03/21 09:54:47 hatchond Exp $
;;; $Id: misc.lisp,v 1.4 2003/04/07 13:35:32 hatchond Exp $
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -94,7 +94,7 @@
(defun wm-name (window)
(or (ignore-errors (netwm:net-wm-name window))
(ignore-errors (xlib:wm-name window))
(format nil "incognito")))
(defun wm-icon-name (window)
(or (ignore-errors (netwm:net-wm-icon-name window))
......@@ -161,3 +161,29 @@
(defsetf geometry (geometry) (x y w h)
`(setf (geometry-x ,geometry) ,x (geometry-y ,geometry) ,y
(geometry-w ,geometry) ,w (geometry-h ,geometry) ,h))
;;; application inspection functions
(defun application-list ()
"Return the applications objects as a list."
(loop for val being each hash-value in *widget-table*
when (application-p val) collect val))
(defun application-name (app)
(xlib:wm-name (widget-window app)))
(defun application-find (name)
(car (member name (application-list) :test #'equal :key #'application-name)))
(defun application-class (app)
(multiple-value-bind (name type)
(xlib:get-wm-class (widget-window app))
(cons name type)))
(defun application-class-name (app)
(car (application-class app)))
(defun application-class-type (app)
(cdr (application-class app)))
;;;; misc.lisp ends here.
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.4 2003/03/19 09:52:38 hatchond Exp $
;;; $Id: widgets.lisp,v 1.5 2003/03/21 09:54:47 hatchond Exp $
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -105,8 +105,8 @@
(ignore-errors (give-focus-to-next-widget-in-desktop *root*)))
(when *change-desktop-message-active-p*
(timed-message-box *root-window*
(or (nth new-screen (workspace-names *root-window*))
(format nil "WORKSPACE ~a" new-screen)))))))
(or (nth new-screen (workspace-names *root-window*))
(format nil "WORKSPACE ~a" new-screen)))))))
(defun get-visible-windows (vscreens)
(loop for window across (vs:nth-vscreen vscreens)
......@@ -285,7 +285,7 @@
(let* ((hint (ignore-errors (xlib:get-property window :WM_HINTS)))
(protocols (ignore-errors (xlib:wm-protocols window)))
(input-p (and hint (logbitp 0 (first hint)) (= 1 (second hint))))
(take-focus-p (member :wm_take_focus protocols)))
(take-focus-p (ignore-errors (member :wm_take_focus protocols))))
(cond ((and (not input-p) (not take-focus-p)) :no-input)
((and (not input-p) take-focus-p) :globally-active)
((and input-p (not take-focus-p)) :passive)
......@@ -476,6 +476,7 @@
(defclass icon (push-button)
((desiconify-p :initform nil :accessor icon-desiconify-p)
(creation-time :initform (get-universal-time) :accessor icon-creation-time)
(application :initarg :application :reader icon-application)))
(defun icon-p (widget)
......@@ -485,7 +486,7 @@
&optional (gcontext *gcontext*) (bg-color *black*))
(with-slots (window icon) application
(let ((background (clx-ext::wm-hints-icon-pixmap window))
(width 45) (height 60))
(width 45) (height 20))
(if (typep background 'xlib:pixmap)
(multiple-value-setq (width height) (drawable-sizes background))
(setf background nil))
......@@ -499,14 +500,82 @@
(setf icon (create-button
:parent *root-window* :master master
:x 750 :y 50 :width width :height height
:x 0 :y 0 :width width :height height
:gcontext gcontext
:item (unless background (wm-icon-name window))
:background (or background bg-color))
(slot-value icon 'application) application)
(defun icon-sort-creation-order (icon1 icon2)
(< (icon-creation-time icon1) (icon-creation-time icon2)))
(defun icon-sort-name (icon1 icon2)
(string< (xlib:wm-name (widget-window (icon-application icon1)))
(xlib:wm-name (widget-window (icon-application icon2)))))
(defun icon-sort-type (icon1 icon2)
(let ((c1 (application-class (icon-application icon1)))
(c2 (application-class (icon-application icon2))))
(or (string< (cdr c1) (cdr c2))
(and (string= (cdr c1) (cdr c2))
(string< (car c1) (car c2))))))
(defun icon-box-update ()
(unless (eq *icon-box-fill* :top-right)
(timed-message-box (widget-window *root*)
"Only :top-right fill is currently supported"))
(let ((icons (stable-sort
(loop for val being each hash-value in *widget-table*
when (icon-p val) collect val)
(or *icon-box-sort-function* #'icon-sort-creation-order))))
(flet ((absx (v) (if (< v 0) (+ (screen-width) v) v))
(absy (v) (if (< v 0) (+ (screen-height) v) v)))
(let* ((box-tlx (absx (aref *icon-box* 0))) ;top left x
(box-tly (absy (aref *icon-box* 1)))
(box-brx (absx (aref *icon-box* 2))) ;bottom right y
(box-bry (absy (aref *icon-box* 3)))
(box-trx box-brx)
(box-try box-tly)
(box-blx box-tlx)
(box-bly box-bry)
(box-sizex (- box-trx box-tlx))
(box-sizey (- box-bry box-try))
(prev-icon-window nil)
(maxedge 0)
(basex 0)
(basey nil))
(declare (ignore box-sizey box-sizex box-blx))
(dolist (icon icons)
(let* ((icon-window (widget-window icon))
(icon-x (xlib:drawable-x icon-window))
(icon-y (xlib:drawable-y icon-window)))
(setq maxedge (max (xlib:drawable-width icon-window) maxedge)
basex (- box-trx maxedge *icon-box-sep*)
basey (if (not basey)
(+ basey
(xlib:drawable-height prev-icon-window)
(when (> basey box-bry)
(setq basey box-try
basex (- basex maxedge *icon-box-sep*)
maxedge (xlib:drawable-width icon-window)))
(when (< basex box-tlx)
;;if the box overflows, we put the icon into (0,0)
(setq basex 0 basey 0))
((and (= basex icon-x) (= basey icon-y)))
((or (< 0 basex box-tlx) (> basex box-trx)
(< 0 basey box-tly) (> basey box-bly)))
(xlib:with-state (icon-window)
(setf (xlib:drawable-x icon-window) basex
(xlib:drawable-y icon-window) basey))))
(setq prev-icon-window icon-window)))))))
(defmethod iconify ((application application))
(with-slots (window iconic-p wants-focus-p icon) application
(setf iconic-p t wants-focus-p t)
(xlib:unmap-window window)
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.9 2003/03/19 10:15:23 hatchond Exp $
;;; $Id: wm.lisp,v 1.10 2003/03/21 09:54:48 hatchond Exp $
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -22,7 +22,7 @@
;;; 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 garbadge collection.
;; usefull for having a quick and short garbage collection.
#+:cmu (setf extensions:*bytes-consed-between-gcs* 400000
extensions:*gc-verbose* nil)
......@@ -634,8 +634,6 @@
;; Sets the root window pop-up menu
(nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '()))
; I want to disable the exit part for the moment.
(setf *menu-1-items* (butlast *menu-1-items*))
(with-slots (menu1 menu3) *root*
(setf menu1 (apply #'make-pop-up *root* *menu-1-items*)
menu3 (make-pop-up *root*
......@@ -676,8 +674,9 @@
(event-process event (lookup-widget event-window)))))
(when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
(case exit
(1 (loop for val being each hash-value in *widget-table*
do (close-widget val))
(1 (when *close-display-p*
(loop for val being each hash-value in *widget-table*
do (close-widget val)))
(setf time 10 exit 2))
(2 (return))))))
(format t "Main loop exited~%")))
Supports Markdown
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