Commit 277c7476 authored by Iban Hatchondo's avatar Iban Hatchondo
Browse files

add support for icon as described in the exwm spec.

 - decode-netwm-icon-pixmap (misc.lisp)
 - small impacts in gestures.lisp & widgets.lisp.

add a new callback on the application list root menu:
 when no window on a desktop then releasing the mouse button on such an entry
 will put you on that desktop. (wm.lisp)

package.lisp updated.
parent 4f5ecba3
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: gestures.lisp,v 1.10 2003/11/13 11:12:28 ihatchondo Exp $
;;; $Id: gestures.lisp,v 1.11 2003/11/19 10:29:08 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -255,7 +255,7 @@
(default-modifiers-p t)
(modifiers :any)
fun)
" modifiers can be:
" modifiers can be:
- composition of modifiers as '(:and :ALT-LEFT :CONTROL-RIGHT)
- a simple modifier as :ALT-LEFT or 18 (a modifier mask)
- a list of possible modifiers as '(:ALT-LEFT :CONTOL-RIGHT)"
......@@ -276,7 +276,7 @@
(default-modifiers-p t)
(modifiers :any)
fun)
" modifiers can be:
" modifiers can be:
- composition of modifiers as '(:and :ALT-LEFT :CONTROL-RIGHT)
- a simple modifier as :ALT-LEFT or 18 (a modifier mask)
- a list of possible modifiers as '(:ALT-LEFT :CONTOL-RIGHT)"
......@@ -386,9 +386,10 @@
(when (eq direction :below) (incf depth-aux))
(rotatef (nth 0 *windows*) (nth depth-aux *windows*)))))
(when (and *verbose-window-cycling* (car *windows*))
(with-slots (window) (lookup-widget (car *windows*))
(with-slots (window icon) (lookup-widget (car *windows*))
(setf (message-pixmap *current-widget-info*)
(clx-ext::wm-hints-icon-pixmap window))
(or (icon-pixmap-to-free icon)
(clx-ext::wm-hints-icon-pixmap window)))
(setf (button-item-to-draw *current-widget-info*) (wm-name window)))
(with-slots (window) *current-widget-info*
(xlib:map-window window)
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.22 2003/11/24 13:12:01 ihatchondo Exp $
;;; $Id: input.lisp,v 1.23 2003/11/24 13:44:50 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -374,16 +374,16 @@
(let* ((cur-desk (window-desktop-num window))
(new-desk (aref data 0))
(master-window (and master (widget-window master)))
(unmap-p (/= new-desk +any-desktop+ (current-desk))))
(unmap-p (/= new-desk +any-desktop+ (current-desk)))
(operation (if unmap-p #'xlib:unmap-window #'xlib:map-window)))
(unless (= cur-desk new-desk)
(when (shaded-p application) (shade application))
(setf (window-desktop-num window) new-desk)
(let ((operation (if unmap-p #'xlib:unmap-window #'xlib:map-window)))
(with-event-mask (*root-window*)
(funcall operation (or master-window window))
(when master-window
(with-event-mask (master-window)
(funcall operation window)))))
(with-event-mask (*root-window*)
(funcall operation (or master-window window))
(when master-window
(with-event-mask (master-window)
(funcall operation window))))
(when unmap-p
(xlib:set-input-focus *display* :pointer-root :pointer-root)))))
(:_NET_CLOSE_WINDOW (close-widget application))
......@@ -488,4 +488,4 @@
;;; Events for Message Box
(defmethod event-process ((event visibility-notify) (box box-button))
(setf (xlib:window-priority (widget-window box)) :above))
\ No newline at end of file
(setf (xlib:window-priority (widget-window box)) :above))
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: misc.lisp,v 1.13 2003/11/13 11:12:28 ihatchondo Exp $
;;; $Id: misc.lisp,v 1.14 2003/11/19 10:29:08 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -29,7 +29,6 @@
"~/"))
directory))
;;;; Helpers macros.
(defmacro with-gensym (symbols &body body)
......@@ -116,6 +115,32 @@
(ignore-errors (xlib:wm-icon-name window))
"incognito"))
(defun decode-netwm-icon-pixmap (window property-vector)
"Return a pixmap containing the first icon of the property or NIL."
;;(declare (optimize (speed 3) (safety 1)))
(declare (type (or null (simple-vector *)) property-vector))
(unless property-vector (return-from decode-netwm-icon-pixmap nil))
(loop with depth of-type ppm::card-8 = (xlib:drawable-depth window)
with bits-per-pixel = (ppm::find-bits-per-pixel depth)
with type = `(unsigned-byte ,depth)
with width of-type ppm::card-16 = (aref property-vector 0)
with height of-type ppm::card-16 = (aref property-vector 1)
with size of-type ppm::card-32 = (* width height)
with data = (make-array (list height width) :element-type type)
with tmp = (make-array size :displaced-to data :element-type type)
for i of-type ppm::card-32 from 2 below (+ 2 size)
for argb of-type ppm::card-32 = (aref property-vector i)
for r of-type ppm::card-8 = (ldb (byte 8 16) argb)
for g of-type ppm::card-8 = (ldb (byte 8 8) argb)
for b of-type ppm::card-8 = (ldb (byte 8 0) argb)
do (setf (aref tmp (- i 2)) (ppm::get-color r g b))
finally (return
(xlib:image-pixmap
window
(xlib:create-image
:width width :height height :depth depth
:bits-per-pixel bits-per-pixel :data data)))))
(defun window-desktop-num (window)
(or (netwm:net-wm-desktop window) (gnome:win-workspace window)))
......
;;; -*- Mode: Lisp; Package: User -*-
;;; $Id: package.lisp,v 1.10 2003/10/09 11:40:38 ihatchondo Exp $
;;; $Id: package.lisp,v 1.11 2003/11/24 16:57:46 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -80,6 +80,7 @@
"CREATE-ICON" ;function
"CREATE-MESSAGE-BOX" ;function
"CURRENT-VSCREEN" ;function
"DECODE-NETWM-ICON-PIXMAP" ;function
"DECORATION-P" ;function
"DECORATION-THEME" ;setf function
"DECORE-APPLICATION" ;function
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.19 2003/11/08 19:54:13 ihatchondo Exp $
;;; $Id: widgets.lisp,v 1.20 2003/11/24 13:12:02 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -557,33 +557,37 @@
(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)))
(application :initarg :application :reader icon-application)
(pixmap-to-free :initform nil :reader icon-pixmap-to-free)))
(defun icon-p (widget)
(typep widget 'icon))
(defun create-icon (application master &optional (bg-color *black*))
(with-slots (window icon gcontext) application
(let ((background (clx-ext::wm-hints-icon-pixmap window))
(width 45) (height 20))
(let* ((bkgrd (decode-netwm-icon-pixmap window (netwm:net-wm-icon window)))
(width 45) (height 20) (pixmap-to-free bkgrd))
(unless bkgrd
(setf bkgrd (ignore-errors (clx-ext::wm-hints-icon-pixmap window))))
(ignore-errors
(if (typep background 'xlib:pixmap)
(multiple-value-setq (width height) (drawable-sizes background))
(setf background nil)))
(if (typep bkgrd 'xlib:pixmap)
(multiple-value-setq (width height) (drawable-sizes bkgrd))
(setf bkgrd nil)))
(ignore-errors
(when (and background (= 1 (xlib:drawable-depth background)))
(when (and bkgrd (= 1 (xlib:drawable-depth bkgrd)))
(let ((pix (xlib:create-pixmap
:drawable window :width width :height height
:depth (xlib:drawable-depth window))))
(xlib:copy-plane background gcontext 1 0 0 width height pix 0 0)
(setf background pix))))
(xlib:copy-plane bkgrd gcontext 1 0 0 width height pix 0 0)
(setf bkgrd pix))))
(setf icon (create-button
'icon
:parent *root-window* :master master
:x 0 :y 0 :width width :height height
:item (unless background (wm-icon-name window))
:background (or background bg-color))
(slot-value icon 'application) application)
:item (unless bkgrd (wm-icon-name window))
:background (or bkgrd bg-color)))
(setf (slot-value icon 'pixmap-to-free) pixmap-to-free)
(setf (slot-value icon 'application) application)
icon)))
(defun icon-sort-creation-order (icon1 icon2)
......@@ -652,6 +656,11 @@
(setf (window-position icon-window) (values basex basey)))))
(setq prev-icon-window icon-window)))))))
(defmethod remove-widget :after ((widget icon))
(with-slots (pixmap-to-free) widget
(when pixmap-to-free
(xlib:free-pixmap pixmap-to-free))))
(defmethod repaint ((widget icon) theme-name focus)
(declare (ignorable theme-name focus))
(with-slots (window item-to-draw gcontext) widget
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.23 2003/11/19 10:29:08 ihatchondo Exp $
;;; $Id: wm.lisp,v 1.24 2003/11/24 16:57:46 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -592,11 +592,13 @@
(1 (change-vscreen root :n index))
(3 (uniconify (slot-value (lookup-widget window) 'icon))))
(put-on-top (lookup-widget window))))
(make-desktop-entries (index)
(loop for w in (screen-content index :iconify-p t)
(make-desktop-entries (i)
(loop for w in (screen-content i :iconify-p t)
for state = (= 1 (first (wm-state w)))
collect (cons (format nil "~:[[ ~A ]~;~A~]" state (wm-name w))
(raise w index)))))
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)
......
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