;; 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) )))