498 lines
18 KiB
Plaintext
498 lines
18 KiB
Plaintext
;; 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)
|
|
)))
|
|
|