1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
|
;; virtual.gwm --- Virtual Screen
;;
;; Author: Anders Holst (aho@sans.kth.se)
;; Copyright (C) 1995 Anders Holst
;; Version: virtual-1.0
;; Last change: 25/10 1996
;;
;; This file is copyrighted under the same terms as the rest of GWM
;; (see the X Inc license for details). There is no warranty that it
;; works.
;;
;; ---------------------------------------------------------------------
;;
;; NOTE: To use this virtual screen in other profiles then the VTWM
;; profile, load "load-virtual.gwm" instead, which sets up the
;; necessary environment and loads the relevant files.
;;
;; This code is inspired by and in large parts stolen from the vscreen
;; code my Emanuel Jay Berkenbilt, MIT.
;;
;; Differences from vscreen.gwm include:
;; * The map looks neater, and the colors are highly customable.
;; * It is updated automatically when the window configuration changes.
;; * You can move the real screen or specific windows by clicking or
;; dragging on the map.
;;
;; A good function to put into the window menu is '(virtual-toggle-nail)',
;; a function for the root-menu is '(virtual-toggle)', and something
;; to call from eg. an icon manager is '(virtual-make-window-visible)'.
;;
;; I hope that the variables below are self explanatory. However, the
;; variable 'virtual-fancy-colors' might need an explanation, via an
;; example:
;;
;; (setq virtual-fancy-colors (list
;; (list black (color-make "lightgray")) ; real screen border and background
;; (list 'Emacs black (color-make "lightpink")) ; emacs border and bg
;; (list 'XTerm black (color-make "lightskyblue")) ; xterm border and bg
;; (list t black white))) ; all other windows
;;
(declare-screen-dependent
virtual-modifiers
virtual-omit-nailed
virtual-omit-list
virtual-show-filled
virtual-fancy-colors
virtual-xpos
virtual-ypos
virtual-pixsize
virtual-background
virtual-foreground
virtual-title-font
virtual-title-position
virtual-horizontal-step
virtual-vertical-step
virtual-nailed-list
virt-added-window
virt-removed-window
virt-pos
virt-wind
virt-pix
)
;;
;; USER CUSTOMIZABLE VARIABLES
;; ---------------------------
;; Adjust these in your own profile
;;
(for screen (list-of-screens)
(defaults-to
show-virtual t ; Show the map of the virtual screen
virtual-modifiers (together with-control with-alt) ; modifs for arrow keys
virtual-omit-nailed t ; if t, map shows only non-nailed windows
virtual-omit-list () ; list of windows not shown in map
virtual-show-filled t ; windows not drawn transparent in map
virtual-fancy-colors () ; list of (wind-class fg bg) specs.
virtual-xpos 0 ; original position of map
virtual-ypos 0
virtual-pixsize 160 ; size of the map
virtual-background white ; default background of the map
virtual-foreground black ; default window frame color on the map
virtual-title-font () ; font of window titles in the map
virtual-title-position () ; position of titles in the map, could be
; top, center, bottom, above, or below.
virtual-horizontal-step (/ screen-width 2) ; amount to move by keys
virtual-vertical-step (/ screen-height 2)
virtual-nailed-list '(Gwm) ; initially nailed windows
)
)
(for screen (list-of-screens) ; Dont touch these
(setq virt-pos (list 0 0))
(setq virt-added-window ())
(setq virt-removed-window ())
)
;; Note: Uses 'matches-list' from vtwm.gwm
(defun virtual-nailed ()
;; Determine whether the current window is nailed or not.
(if (setq tmp (# 'nailed window-window))
(not (= 'no tmp))
(if (or (matches-list virtual-nailed-list)
(and (= window-client-class 'Gwm)
(= window-name 'virtual)))
(progn
(virtual-nail)
t)
(progn
(virtual-unnail)
()))))
(defun virtual-nail ()
(## 'nailed window-window t))
(defun virtual-unnail ()
(## 'nailed window-window 'no))
(defun virtual-toggle-nail ()
(if (virtual-nailed)
(virtual-unnail)
(virtual-nail))
(if virtual-omit-nailed
(virtual-update)))
(defun virt-movable ()
;; Returns a list of movable windows
(with (movable nil)
(for wob (list-of-windows 'window)
(if (not (virtual-nailed))
(setq movable (+ movable (list window)))))
movable))
(defun virtual-move-windows (deltax deltay)
;; Moves windows by deltax and deltay adjusting virt-pos
;; appropriately
(with (move-window-func (if (boundp 'move-window-orig)
move-window-orig ; to work with vtwm profile
move-window))
(for wob (virt-movable)
(move-window-func (+ window-x deltax) (+ window-y deltay))))
(with (x (# 0 virt-pos) y (# 1 virt-pos))
(setq virt-pos (list (+ x deltax) (+ y deltay))))
(virtual-update))
(defun virtual-move-left ()
(virtual-move-windows virtual-horizontal-step 0))
(defun virtual-move-right ()
(virtual-move-windows (- virtual-horizontal-step) 0))
(defun virtual-move-up ()
(virtual-move-windows 0 virtual-vertical-step))
(defun virtual-move-down ()
(virtual-move-windows 0 (- virtual-vertical-step)))
(defun virtual-move-home ()
(virtual-move-windows (- (# 0 virt-pos))
(- (# 1 virt-pos))))
(defun virtual-move-to (x y)
(virtual-move-windows (- (+ x (# 0 virt-pos)))
(- (+ y (# 1 virt-pos)))))
(defun virtual-make-window-visible ()
;; Move the virtual screen to make the current window visible.
(if (not (virtual-nailed))
(with (dx 0 dy 0
window-top window-y
window-bot (+ window-y window-height)
window-left window-x
window-right (+ window-x window-width)
screen-top 0
screen-bot screen-height
screen-left 0
screen-right screen-width)
(if (or (ge window-left screen-right) ; Check that no part visible
(le window-right screen-left)
(ge window-top screen-bot)
(le window-bot screen-top))
(progn
(if (ge window-right screen-right)
(setq dx (- (ceildiv (min (- window-right screen-right)
(- window-left screen-left
virtual-horizontal-step))
virtual-horizontal-step))))
(if (le window-left screen-left)
(setq dx (ceildiv (- screen-left window-left)
virtual-horizontal-step)))
(if (ge window-bot screen-bot)
(setq dy (- (ceildiv (min (- window-bot screen-bot)
(- window-top screen-top
virtual-vertical-step))
virtual-vertical-step))))
(if (le window-top screen-top)
(setq dy (ceildiv (- screen-top window-top)
virtual-vertical-step)))
(setq dx (* dx virtual-horizontal-step))
(setq dy (* dy virtual-vertical-step))
(virtual-move-windows dx dy))))))
(defun virtual-placement (flag)
(if flag
(if (not (or window-was-on-screen
;; window-starts-iconic
;; window-is-transient-for
(not (= window-status 'window))))
(if (and (not (virtual-nailed))
(not (= virt-pos '(0 0))))
(move-window (+ window-x (# 0 virt-pos))
(+ window-y (# 1 virt-pos)))))))
(defun virtual-x (x)
(- x (# 0 virt-pos)))
(defun virtual-y (y)
(- y (# 1 virt-pos)))
(defun virt-drawable ()
(and (not (= window virt-removed-window))
(not (and virtual-omit-nailed
(virtual-nailed)))
(not (matches-list virtual-omit-list))))
(defun virt-calc-params ()
;; Return a list that contains scale factor, x position of origin,
;; and y position of origin
(with (minx 0
miny 0
maxx screen-width
maxy screen-height
xcenter nil ycenter nil
range nil scale nil x0 nil y0 nil
low (list-of-windows 'window 'mapped))
(if (not (wob-is-valid wob))
(wob root-window))
(for wob (if virt-added-window
(+ (list-of-windows 'window 'mapped)
(list virt-added-window))
(list-of-windows 'window 'mapped))
(if (virt-drawable)
(progn
(setq minx (min minx window-x))
(setq miny (min miny window-y))
(setq maxx (max maxx (+ window-x window-width)))
(setq maxy (max maxy (+ window-y window-height))))))
(setq range (max (- maxy miny) (- maxx minx)))
(setq xcenter (/ (+ minx maxx) 2))
(setq ycenter (/ (+ miny maxy) 2))
;; Our scale factor is a simple quotient, times ten. We divide
;; by .95 times the number of pixels to leave some inner border.
;; To get the origin, figure out where 0,0 would be given that
;; the center of the current screen should be in the center.
(setq scale (/ (* 1000 range) (* 95 virtual-pixsize)))
(setq x0 (/ virtual-pixsize 2))
(setq y0 (/ virtual-pixsize 2))
(setq x0 (- x0 (/ (* 10 xcenter) scale)))
(setq y0 (- y0 (/ (* 10 ycenter) scale)))
(list scale x0 y0)))
(defun virt-draw-text (pix left top wdt hgt name vfont pos)
(with (font vfont
label-vertical-margin 0
label-horizontal-margin 0
fh (height " ")
yoff (- fh 2))
(if pos
(setq yoff (if (= (setq pos (atom pos)) 'top) (- fh 2)
(= pos 'center) (/ (+ hgt fh -6) 2)
(= pos 'bottom) (- hgt 1)
(= pos 'above) -2
(= pos 'below) (+ hgt fh -1)
(- fh 2))))
(if (or (not pos) (= pos 'center) (= pos 'bottom) (= pos 'top))
(while (and (> (width name) wdt) (> (length name) 0))
(setq name (match "\\(.*\\).$" name 1))))
(draw-text pix (+ 1 left) (+ yoff top) vfont name)))
(defun virt-draw-window (pix params border colf colb)
(with (foreground colf
background (or colb 0)
mode (if colb 3 1)
left (+ (/ (* 10 window-x) (# 0 params)) (# 1 params))
top (+ (/ (* 10 window-y) (# 0 params)) (# 2 params))
wdt (/ (* 10 window-width) (# 0 params))
hgt (/ (* 10 window-height) (# 0 params)))
(draw-rectangle pix left top wdt hgt border mode)
(if (and virtual-title-font (not (= wob root-window)))
(virt-draw-text pix left top wdt hgt window-name
virtual-title-font virtual-title-position))))
(defun virt-get-color ()
(with (res (if (= window root-window)
(with (ele (# 0 virtual-fancy-colors))
(if (and ele
(or (not (# 0 ele))
(= (type (# 0 ele)) 'number)))
ele))
(matches-cond virtual-fancy-colors)))
(if (not res)
(list virtual-foreground
(if virtual-show-filled
virtual-background
()))
(not (# 0 res))
(list virtual-foreground
(# 1 res))
res)))
(defun virt-draw-windows (pix params)
(with (wob root-window
cols (virt-get-color))
(virt-draw-window pix params 2 (# 0 cols) (# 1 cols)))
(for wob (if virt-added-window
(+ (list-of-windows 'window 'stacking-order 'mapped)
(list virt-added-window))
(list-of-windows 'window 'stacking-order 'mapped))
(if (virt-drawable)
(with (cols (virt-get-color))
(virt-draw-window pix params 1 (# 0 cols) (# 1 cols))))))
(defun virt-map-to-real (params relx rely)
(with (absx (/ (* (- relx (# 1 params)) (# 0 params)) 10)
absy (/ (* (- rely (# 2 params)) (# 0 params)) 10))
(list absx absy)))
(defun virt-real-to-map (params realx realy)
(with (mapx (+ (/ (* realx 10) (# 0 params)) (# 1 params))
mapy (+ (/ (* realy 10) (# 0 params)) (# 2 params)))
(list mapx mapy)))
(defun virtual-map-move-to ()
(with (params (virt-calc-params)
realpos (virt-map-to-real params
(current-event-relative-x)
(current-event-relative-y))
hswdt virtual-horizontal-step
hshgt virtual-vertical-step
absx (- (# 0 realpos) (# 0 virt-pos) (/ screen-width 2))
absy (- (# 1 realpos) (# 1 virt-pos) (/ screen-height 2))
absx (if (< absx 0)
(* hswdt (/ (- absx (/ hswdt 2)) hswdt))
(* hswdt (/ (+ absx (/ hswdt 2)) hswdt)))
absy (if (< absy 0)
(* hshgt (/ (- absy (/ hshgt 2)) hshgt))
(* hshgt (/ (+ absy (/ hshgt 2)) hshgt))))
(virtual-move-to absx absy)))
(defun virtual-map-move-window ()
(with (params (virt-calc-params)
wob virt-wind
mapleft (+ window-x wob-borderwidth
window-client-x window-client-borderwidth -1)
maptop (+ window-y wob-borderwidth
window-client-y window-client-borderwidth -1)
mapright (+ mapleft window-client-width)
mapbottom (+ maptop window-client-height)
mappos (current-mouse-position)
bmask 7936
init-button (bitwise-and bmask (# 2 mappos))
realpos (virt-map-to-real params
(- (# 0 mappos) mapleft)
(- (# 1 mappos) maptop))
wind (wob-at-coords (# 0 realpos) (# 1 realpos)))
(virtual-update)
(if (and wind
(with (wob wind) (virt-drawable)))
(with (wob wind
initpos (virt-real-to-map params window-x window-y)
mouse-pos ()
cursor (cursor-make 130))
(virt-draw-window virt-pix params 2 virtual-foreground ())
(refresh virt-wind)
(process-events)
(tag ret
(grab-server root-window)
(warp-pointer (+ (# 0 initpos) mapleft)
(+ (# 1 initpos) maptop)
root-window)
(warp-pointer 0 0) ; To get around bug in X11
(while t
(: mouse-pos (current-mouse-position))
(if (not (= (bitwise-and bmask (# 2 mouse-pos)) init-button))
(exit ret
(ungrab-server root-window)))))
(if (and (= (bitwise-and bmask (# 2 mouse-pos)) 0)
(not (and (= (# 0 mouse-pos) (+ (# 0 initpos) mapleft))
(= (# 1 mouse-pos) (+ (# 1 initpos) maptop))))
(> (# 0 mouse-pos) mapleft)
(< (# 0 mouse-pos) mapright)
(> (# 1 mouse-pos) maptop)
(< (# 1 mouse-pos) mapbottom))
(with (newpos (virt-map-to-real params
(- (# 0 mouse-pos) mapleft)
(- (# 1 mouse-pos) maptop)))
(move-window wind (# 0 newpos) (# 1 newpos))))
(virtual-update)))))
(defun virtual-show ()
(if (and (boundp 'virt-wind) virt-wind (wob-is-valid virt-wind))
(with (wob virt-wind
left (+ window-x wob-borderwidth
window-client-x window-client-borderwidth)
top (+ window-y window-client-y
wob-borderwidth window-client-borderwidth))
(setq virtual-xpos left)
(setq virtual-ypos top)
(delete-window)))
(if show-virtual
(with (params (virt-calc-params)
vmenu ())
(with (foreground virtual-background)
(setq virt-pix (pixmap-make virtual-pixsize virtual-pixsize)))
(virt-draw-windows virt-pix params)
(setq vmenu
(with (borderwidth 0
bar-max-width virtual-pixsize
fsm (fsm-make virtual-map-behavior))
(menu-make (bar-make (plug-make virt-pix)))))
(process-events)
(with (reenter-on-opening ()
xpos (if (< virtual-xpos 0)
(- (+ screen-width virtual-xpos) virtual-pixsize)
virtual-xpos)
ypos (if (< virtual-ypos 0)
(- (+ screen-height virtual-ypos) virtual-pixsize)
virtual-ypos))
(setq virt-wind
(place-menu 'virtual vmenu xpos ypos))))
(progn
(unbind 'virt-wind)
(unbind 'virt-pix))))
(defun virtual-toggle ()
(: show-virtual (not show-virtual))
(virtual-show))
(defun virtual-update ()
(if (and show-virtual (boundp 'virt-pix) (boundp 'virt-wind))
(with (params (virt-calc-params)
bar-max-width virtual-pixsize)
(with (background virtual-background)
(draw-rectangle virt-pix 0 0 virtual-pixsize virtual-pixsize 0 2))
(virt-draw-windows virt-pix params)
(refresh virt-wind))))
(defun virtual-add ()
(if (and (not (= window-status 'icon))
(not (= window-client-class 'Gwm)))
(with (virt-added-window window)
(virtual-update))))
(defun virtual-remove ()
(if (and (not (= window-status 'icon))
(not (= window-client-class 'Gwm)))
(with (virt-removed-window window)
(virtual-update))))
(if (not (boundp 'virtual-map-behavior))
(: virtual-map-behavior
(state-make
(on (button 1 any) (virtual-map-move-to))
(on (buttonpress 2 any) (virtual-map-move-window))
(on (button 3 any) (virtual-update))
))
)
(defun virtual-behavior ()
(if virtual-modifiers
(state-make
(on (keypress "Left" virtual-modifiers)
(virtual-move-left))
(on (keypress "Right" virtual-modifiers)
(virtual-move-right))
(on (keypress "Up" virtual-modifiers)
(virtual-move-up))
(on (keypress "Down" virtual-modifiers)
(virtual-move-down)))))
(defun virtual-grabs ()
(if virtual-modifiers
(list
(key "Left" virtual-modifiers)
(key "Right" virtual-modifiers)
(key "Up" virtual-modifiers)
(key "Down" virtual-modifiers)
)))
|
