« back to all changes in this revision
Viewing changes to pile.jl
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Bazaar Package Importer
- Author(s): Christian Marillat
- Date: 2004-07-28 15:21:44 UTC
- mfrom: (1.2.1 upstream) (2.1.1 warty)
- Revision ID: james.westby@ubuntu.com-20040728152144-1b1tm5ak371o1pe9
Tags: 1.3.1-1
* New upstream relase.
* Remove old dependency on sawfish-gnome and sawfish2
* Remove old dependency on sawfish-gnome and sawfish2
added
removed
pile.jl
1
;; merlin/pile.jl -- a bad pile
2
3
;; version -0.3.1
4
5
;; Copyright (C) 2002 merlin <merlin@merlin.org>
6
7
;; http://merlin.org/sawfish/
8
9
;; This is free software; you can redistribute it and/or modify it
10
;; under the terms of the GNU General Public License as published by
11
;; the Free Software Foundation; either version 2, or (at your option)
12
;; any later version.
13
14
;; This is distributed in the hope that it will be useful, but
15
;; WITHOUT ANY WARRANTY; without even the implied warranty of
16
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17
;; GNU General Public License for more details.
18
19
;; You should have received a copy of the GNU General Public License
20
;; along with sawfish; see the file COPYING. If not, write to
21
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23
;;;;;;;;;;;;;;;;;;;;;
24
;; HERE BE DRAGONS ;;
25
;;;;;;;;;;;;;;;;;;;;;
26
27
;; This software requires a patch to be applied to the Sawfish source to
28
;; add some additional XLib bindings.
29
30
;; Please see x.c.patch.
31
32
;;;;;;;;;;;;;;;;;;
33
;; INSTALLATION ;;
34
;;;;;;;;;;;;;;;;;;
35
36
;; Create a directory ~/.sawfish/lisp/merlin and then put this file there:
37
;; mkdir -p ~/.sawfish/lisp/merlin
38
;; mv pile.jl ~/.sawfish/lisp/merlin
39
40
;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl.
41
42
;; You're probably best off unpacking the entire merlin.tgz archive.
43
44
;; Then add to your .sawfishrc:
45
;; (require 'merlin.pile)
46
;; (defpile pile)
47
;; ; `pile' is the name of the pile; you can choose any name you
48
;; ; want, and have multiple piles.
49
50
;; Then restart sawfish. A pile should appear.
51
52
;; Go to Customize->Sawlets->Pile
53
;; - Here you can customize the behaviour of the pile.
54
55
;; Next, go to Customize->Matched Windows
56
;; - Here you must add a matched window setting for any fish that you
57
;; want captured to have Place mode pile.
58
59
;; Now, restart your apps. Hopefully they'll be in the pile.
60
61
;; You can create multiple piles and can configure them programatically
62
;; at creation if you want..
63
64
;;;;;;;;;;;;;;;;;;
65
;; HERE BE BUGS ;;
66
;;;;;;;;;;;;;;;;;;
67
68
;; This is PRE-ALPHA INCOMPLETE SOFTWARE!
69
70
;; this is a bit hacky!
71
72
;; todo: should I tell windows they've moved??
73
74
;; see fishbowl
75
76
;; beos-window-menu is hardwired in, which may not be cool
77
78
;;;;
79
80
(define-structure merlin.pile
81
(export
82
defpile
83
pile-p
84
popup-pile-menu
85
pile-window-menu)
86
87
(open
88
rep
89
rep.regexp
90
rep.system
91
rep.io.timers
92
sawfish.wm.colors
93
sawfish.wm.commands
94
sawfish.wm.events
95
sawfish.wm.fonts
96
sawfish.wm.frames
97
sawfish.wm.menus
98
sawfish.wm.placement
99
sawfish.wm.misc
100
sawfish.wm.stacking
101
sawfish.wm.windows
102
sawfish.wm.ext.beos-window-menu
103
sawfish.wm.util.display-window
104
sawfish.wm.util.x
105
merlin.sawlet
106
merlin.util
107
merlin.x-util)
108
109
;;
110
111
(define (pile-p sawlet)
112
(memq sawlet piles))
113
114
(define (dimensions pile)
115
(if (sawlet-active pile)
116
(window-dimensions (sawlet-frame pile))
117
(cons 64 64)))
118
119
(define piles nil)
120
121
(define (start pile)
122
(setq piles (nconc piles (list pile)))
123
(mapc
124
(lambda (window)
125
(when (eq pile (window-get window 'place-mode))
126
(after-add-window-eye window)))
127
(managed-windows)))
128
129
(define (mapchattelry thunk pile)
130
(let*
131
((chattelry (sawlet-get pile 'merlin.pile:chattelry)))
132
(mapc
133
(lambda (chattel)
134
(thunk chattel))
135
chattelry)))
136
137
(define (stop pile)
138
(let*
139
((base (window-position (sawlet-frame pile))))
140
(setq piles (delq pile piles))
141
(mapchattelry
142
(lambda (chattel)
143
;; (x-reparent-window (car chattel) nil base) -- doesn't work anymore
144
(x-map-request (car chattel)))
145
pile)
146
(sawlet-put pile 'merlin.pile:chattelry nil)))
147
148
(define (capture pile)
149
(let*
150
((window (select-window)))
151
(when (and window (not (eq window (sawlet-frame pile))))
152
(window-put window 'place-mode pile)
153
(after-add-window-eye window))))
154
155
(define (eject pile id)
156
(let*
157
((base (window-position (sawlet-frame pile))))
158
(mapchattelry
159
(lambda (chattel)
160
(when (eq id (car chattel))
161
(sawlet-put pile 'suspend t)
162
;; (x-reparent-window id nil base) -- doesn't work anymore?
163
(x-map-request id)
164
(sawlet-put pile 'suspend nil)))
165
pile)
166
(sawlet-put pile 'merlin.pile:chattelry
167
(delete-if (lambda (chattel) (eq id (car chattel))) (sawlet-get pile 'merlin.pile:chattelry)))
168
(sawlet-reconfigure pile)))
169
170
(define (raise pile id)
171
(let (match) ; this is awful; move to front of list
172
(mapchattelry
173
(lambda (chattel)
174
(when (eq id (car chattel)) (setq match chattel)))
175
pile)
176
(sawlet-put pile 'merlin.pile:chattelry
177
(cons match (delete-if (lambda (chattel) (eq id (car chattel))) (sawlet-get pile 'merlin.pile:chattelry)))))
178
;; raising is not necessary if I move the others off..
179
;; (x-configure-window id `((stack-mode . top-if)))
180
(replace pile)) ;; awful
181
182
(define (constrain value hints axis) ;; TODO: min-aspect / max-aspect
183
(let
184
((minn (or (cdr (assq (intern (format nil "min-%s" axis)) hints)) 1))
185
(maxx (or (cdr (assq (intern (format nil "max-%s" axis)) hints)) 10000))
186
(base (or (cdr (assq (intern (format nil "base-%s" axis)) hints)) 0))
187
(inc (or (cdr (assq (intern (format nil "%s-inc" axis)) hints)) 1)))
188
(max minn (min maxx (+ base (* inc (quotient (- value base) inc)))))))
189
190
(define (replace pile)
191
(let
192
((root (sawlet-get pile 'root))
193
(chattel (car (sawlet-get pile 'merlin.pile:chattelry)))
194
(dim (cons- (dimensions pile) 10)) ; for demo purposes
195
(x 0) (y 0))
196
(x-set-wm-name root
197
(if chattel
198
(format nil "%s - %s" pile
199
(aref (x-get-text-property (car chattel) 'WM_NAME) 0))
200
"pile"))
201
(mapchattelry
202
(lambda (chattel)
203
(let
204
((width (constrain (car dim) (nth 2 chattel) 'width))
205
(height (constrain (cdr dim) (nth 2 chattel) 'height)))
206
(x-configure-window
207
(car chattel) `((x . ,x) (y . ,y) (width . ,width) (height . ,height))))
208
(setq x (car dim) y (cdr dim)))
209
pile)))
210
211
; TODO: now that I have x-get-window-properties I could query the size hints
212
; during replace, rather than storing them here..
213
; TODO: would it be better to do this in add-window-hook? Wouldn't get framed
214
; before it is deframed...
215
(define (after-add-window-eye window)
216
(let*
217
((pile (window-get window 'place-mode)))
218
(when (and (memq pile piles) (not (sawlet-get pile 'suspend)))
219
(let*
220
((id (window-id window))
221
(dim (window-dimensions window))
222
(chattelry (sawlet-get pile 'merlin.pile:chattelry))
223
(hints (window-size-hints window)))
224
(x-change-window-attributes id `((override-redirect . ,t)))
225
(x-map-notify id) ; this removes it from window-manager
226
(x-change-window-attributes id `((override-redirect . ,nil)))
227
(x-configure-window id `((border-width . 0)))
228
(x-reparent-window id (sawlet-get pile 'window) (cons 0 0))
229
(sawlet-put pile 'merlin.pile:chattelry (cons (list id dim hints) chattelry))
230
(sawlet-reconfigure pile)
231
(x-x-map-window id)))))
232
233
(add-hook 'after-add-window-hook after-add-window-eye)
234
235
;;
236
237
(define (abbreviate name #!optional len)
238
(unless len (setq len 20))
239
(if (> (length name) len)
240
(concat (substring name 0 len) "...")
241
name))
242
243
(define (make-pile-menu pile thunk)
244
(let ((chattelry (sawlet-get pile 'merlin.pile:chattelry)))
245
(mapcar
246
(lambda (chattel)
247
(list (abbreviate (aref (x-get-text-property (car chattel) 'WM_NAME) 0))
248
(lambda () (thunk chattel))
249
(cons 'check (and (eq chattel (car chattelry))))
250
(cons 'group (sawlet-symbol pile 'window-menu))))
251
chattelry)))
252
253
(define (popup-pile-menu window)
254
(let*
255
((pile (sawlet-from-frame window)))
256
(when (memq pile piles)
257
(popup-menu
258
`((,(_ "_Capture") ,(lambda () (capture pile)))
259
(,(_ "_Raise") .
260
,(make-pile-menu pile (lambda (chattel) (raise pile (car chattel)))))
261
(,(_ "_Eject") .
262
,(make-pile-menu pile (lambda (chattel) (eject pile (car chattel))))))))))
263
264
(define-command 'popup-pile-menu popup-pile-menu #:spec "%W")
265
266
;;
267
268
;; ignore attempts by piled windows to move/resize themselves
269
(define (configure-request-handler pile event)
270
; (let
271
; ((id (cdr (assq 'window event)))
272
; (width (cdr (assq 'width event)))
273
; (height (cdr (assq 'height event)))
274
; (chattelry (sawlet-get pile 'merlin.pile:chattelry)))
275
; (mapc
276
; (lambda (chattel)
277
; (when (and (equal id (car chattel)))
278
; (rplaca (cdr chattel) (cons width height))
279
; (sawlet-reconfigure pile))) chattelry))
280
t)
281
282
(define (destroy-notify-handler pile event)
283
(let*
284
((id (cdr (assq 'window event)))
285
(chattelry (sawlet-get pile 'merlin.pile:chattelry)))
286
(sawlet-put pile 'merlin.pile:chattelry
287
(delete-if (lambda (chattel) (eq id (car chattel))) chattelry))
288
(sawlet-reconfigure pile))
289
nil)
290
291
(define (expose-handler pile event)
292
(x-clear-window (sawlet-get pile 'window))
293
nil)
294
295
(define (button-press-handler pile event)
296
(popup-pile-menu (sawlet-frame pile))
297
nil)
298
299
(define (pre pile)
300
(define-placement-mode pile (lambda (window))))
301
302
(define (pile-window-menu pile)
303
(or (make-pile-menu pile (lambda (chattel)
304
(raise pile (car chattel))
305
(display-window (sawlet-frame pile))))
306
(list (list "<empty>" (lambda () (display-window (sawlet-frame pile)))))))
307
308
(eval-in ; make the window-menu display pile contents
309
`(progn
310
(require 'merlin.pile)
311
(require 'merlin.sawlet)
312
(define (make-item w)
313
(fluid-set windows-left (delq w (fluid windows-left)))
314
(if (pile-p (sawlet-from-frame w))
315
(cons (make-label w) (lambda () (pile-window-menu (sawlet-from-frame w))))
316
(list (make-label w)
317
(lambda ()
318
(when (windowp w)
319
(display-window w)))
320
(cons 'check (and (eq (input-focus) w)))
321
'(group . beos-window-menu)))))
322
'sawfish.wm.ext.beos-window-menu)
323
324
(defmacro defpile (pile . keys)
325
`(progn
326
(require 'merlin.sawlet)
327
,(append
328
`(defsawlet ,pile
329
:pre ,pre)
330
keys ; allow override
331
`(:start ,start
332
:stop ,stop
333
:post-configure ,replace
334
:wm-size-hints ,(lambda () (cons nil nil))
335
:dimensions ,dimensions
336
:expose-handler ,expose-handler
337
:button-press-handler ,button-press-handler
338
:destroy-notify-handler ,destroy-notify-handler
339
:configure-request-handler ,configure-request-handler
340
:font ,nil
341
:foreground ,nil
342
:background ,(get-color-rgb 0 0 0)
343
:matcher-actions '((place-mode . ,place-window-mode) (frame-type . normal)
344
(never-focus . #f) (sticky . #f) (sticky-viewport . #f) (window-list-skip . #f) (skip-tasklist . #f))
345
)))))
Loggerhead is a web-based interface for Breezy
Version: 2.0.1