559 lines
20 KiB
Plaintext
559 lines
20 KiB
Plaintext
;; virtual-door.gwm --- Doors for the virtual screen in "virtual.gwm"
|
|
;;
|
|
;; Author: Anders Holst (aho@sans.kth.se)
|
|
;; Copyright (C) 1996 Anders Holst
|
|
;; Version: virtual-1.0
|
|
;; Last change: 31/7 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.
|
|
;;
|
|
;; ---------------------------------------------------------------------
|
|
;;
|
|
;; This file defines "doors" on the virtual screen, ie. buttons that
|
|
;; when pressed moves the real screen somewhere on the virtual screen.
|
|
;; The position to move to can be fixed, or given by an expression.
|
|
;;
|
|
;; It also defines some very simple "door managing" functions, to add
|
|
;; or remove doors dynamically.
|
|
;; '(add-door NAME)' adds a door to the next door-less area.
|
|
;; '(add-door NAME 'free)' adds a door to an area free from windows.
|
|
;; '(maybe-add-door NAME)' adds a door (to a window-free area) only
|
|
;; if a door of that name does not exist.
|
|
;; '(goto-door NAME)' moves through a door.
|
|
;; '(remove-door NAME)' removes a door.
|
|
;;
|
|
;; There are some functions dealing with automatic generation and
|
|
;; removal of doors, suitable to call in menus for example. The doors
|
|
;; will have names starting with 'door-auto-string' and a number.
|
|
;; '(fresh-door)' creates a new automatic door in an empty area.
|
|
;; '(clean-doors)' removes automatic doors for empty areas.
|
|
;; '(restore-doors)' adds automatic doors for non-empty areas.
|
|
;; Also, if you call '(make-free-area-door)' when you set up your
|
|
;; initial doors, you will get a "magic" door which when used
|
|
;; creates a new door in place of itself and then moves.
|
|
;;
|
|
|
|
|
|
(declare-screen-dependent
|
|
initial-doors
|
|
door-font
|
|
door-background
|
|
door-foreground
|
|
door-borderwidth
|
|
door-xsize
|
|
door-ysize
|
|
door-mgr-dir-horiz
|
|
door-mgr-dir-len
|
|
door-mgr-mdir-horiz
|
|
door-mgr-mdir-len
|
|
door-mgr-xpos
|
|
door-mgr-ypos
|
|
door-mgr-tile
|
|
door-mgr
|
|
door-mgr-no-outer-border
|
|
door-context
|
|
door-auto-number
|
|
door-auto-string
|
|
door-free-area-string
|
|
door-free-area-color
|
|
door-free-area-cleans
|
|
)
|
|
|
|
;;
|
|
;; USER CUSTOMIZABLE VARIABLES
|
|
;; ---------------------------
|
|
;; Adjust these in your own profile
|
|
;;
|
|
(for screen (list-of-screens)
|
|
(defaults-to
|
|
initial-doors () ; Doors to create on startup
|
|
door-font (font-make "8x13") ; Font in door buttons
|
|
door-background white ; Background color of door buttons
|
|
door-foreground black ; Foreground color of door buttons
|
|
door-borderwidth 2 ; Border width of door buttons
|
|
door-xsize 90 ; Door button size
|
|
door-ysize 16 ; - '' -
|
|
|
|
door-mgr-dir-horiz t ; Controls mapping of doors on virtual screen,
|
|
door-mgr-dir-len 2 ; e.g. two screenfulls in a (horizontal) row.
|
|
door-mgr-mdir-horiz t ; Controls position of door buttons, e.g.
|
|
door-mgr-mdir-len 2 ; place two buttons in each (horizontal) row.
|
|
door-mgr-xpos 0 ; Upper left corner of door manager
|
|
door-mgr-ypos 0 ; - '' -
|
|
door-mgr-tile t ; tile of empty positions, t = transparent
|
|
door-mgr-no-outer-border t ; Leave outermost borders to decoration
|
|
door-context () ; p-list of customizations per door name
|
|
|
|
door-auto-string "Area " ; Name prefix of auto-generated doors
|
|
door-free-area-string "Free Area" ; Name of magic free area door
|
|
door-free-area-color () ; Special color of free area door
|
|
door-free-area-cleans t ; Let free area door clean empty doors
|
|
)
|
|
)
|
|
|
|
|
|
(for screen (list-of-screens)
|
|
(setq door-mgr '(() () () ()))
|
|
(setq door-auto-number 0)
|
|
)
|
|
|
|
(setq door-fsm
|
|
(fsm-make
|
|
(state-make
|
|
(on (buttonpress any alone)
|
|
(with (
|
|
pos (# 'pos wob-property)
|
|
action (# 'action wob-property)
|
|
lst (if (and pos (= (type pos) 'list))
|
|
pos
|
|
(= (type pos) 'quoted-expr)
|
|
(eval (eval pos))
|
|
()))
|
|
(if lst
|
|
(virtual-move-to (# 0 lst) (# 1 lst)))
|
|
(eval action)
|
|
))
|
|
)))
|
|
|
|
(defun door-make (name xpos ypos gotopos)
|
|
(process-events)
|
|
(with (background door-background
|
|
foreground door-foreground
|
|
borderpixel door-foreground
|
|
borderwidth door-borderwidth
|
|
menu-min-width door-xsize
|
|
menu-max-width door-xsize
|
|
bar-min-width door-ysize
|
|
bar-max-width door-ysize
|
|
direction vertical
|
|
reenter-on-opening ())
|
|
(place-menu "door"
|
|
(with (borderwidth 0
|
|
fsm door-fsm
|
|
property (+ (list 'pos gotopos) property))
|
|
(menu-make
|
|
(bar-make
|
|
()
|
|
(plug-make
|
|
(label-make name door-font))
|
|
())))
|
|
xpos ypos)))
|
|
|
|
(defun door-make-plug (name gotopos)
|
|
(with (background door-background
|
|
foreground door-foreground
|
|
tile ()
|
|
borderwidth 0
|
|
bar-min-width door-xsize
|
|
bar-max-width door-xsize
|
|
context (# (atom name) door-context)
|
|
door-action ()
|
|
door-icon ()
|
|
property (+ (list 'pos gotopos 'name name) property)
|
|
fsm door-fsm)
|
|
(with context
|
|
(if door-action
|
|
(setq property (+ (list 'action door-action) property)))
|
|
(bar-make
|
|
(with (bar-min-width door-ysize
|
|
bar-max-width door-ysize
|
|
property ()
|
|
fsm ())
|
|
(bar-make
|
|
()
|
|
(plug-make
|
|
(if door-icon
|
|
door-icon
|
|
(label-make name door-font))
|
|
)
|
|
()))))))
|
|
|
|
(defun door-make-space ()
|
|
(with (background door-background
|
|
foreground door-foreground
|
|
borderwidth 0
|
|
bar-min-width door-xsize
|
|
bar-max-width door-xsize
|
|
tile ()
|
|
fsm ())
|
|
(bar-make
|
|
(with (bar-min-width door-ysize
|
|
bar-max-width door-ysize
|
|
tile door-mgr-tile)
|
|
(bar-make )))))
|
|
|
|
(defun door-make-vborder (ele1 ele2)
|
|
(with (background door-foreground
|
|
borderwidth 0
|
|
bar-min-width door-borderwidth
|
|
bar-max-width door-borderwidth
|
|
tile (if (and (eq door-mgr-tile t)
|
|
(not (or ele1 ele2)))
|
|
t)
|
|
fsm ())
|
|
(bar-make )))
|
|
|
|
(defun door-make-hborder-aux (len tl)
|
|
(with (bar-min-width len
|
|
bar-max-width len
|
|
tile tl)
|
|
(list (bar-make ))))
|
|
|
|
(defun door-make-hborder (lst i1 i2 step num)
|
|
(with (background door-foreground
|
|
borderwidth 0
|
|
bar-min-width door-borderwidth
|
|
bar-max-width door-borderwidth
|
|
tile ()
|
|
fsm ())
|
|
(if (eq door-mgr-tile t)
|
|
(with (tlst (list-make num)
|
|
blst ()
|
|
n 1
|
|
i 0)
|
|
(while (< i num)
|
|
(## i tlst (not (or (# i1 lst) (# i2 lst))))
|
|
(setq i (+ i 1))
|
|
(setq i1 (+ i1 step))
|
|
(setq i2 (+ i2 step)))
|
|
(setq i 0)
|
|
(while (< i num)
|
|
(if (and (< (+ i 1) num) (= (# i tlst) (# (+ i 1) tlst)))
|
|
(setq n (+ n 1))
|
|
(not (# i tlst))
|
|
(progn
|
|
(setq blst (+ blst (door-make-hborder-aux
|
|
(+ (* n (+ door-xsize
|
|
door-borderwidth))
|
|
(if (and (= (+ i 1) n)
|
|
door-mgr-no-outer-border)
|
|
(- door-borderwidth) 0)
|
|
(if (and (= (+ i 1) num)
|
|
door-mgr-no-outer-border)
|
|
(- door-borderwidth) 0)
|
|
door-borderwidth)
|
|
())))
|
|
(setq n 1))
|
|
(progn
|
|
(setq blst (+ blst (door-make-hborder-aux
|
|
(+ (* n (+ door-xsize
|
|
door-borderwidth))
|
|
(if (and (= (+ i 1) n)
|
|
(not door-mgr-no-outer-border))
|
|
door-borderwidth 0)
|
|
(if (and (= (+ i 1) num)
|
|
(not door-mgr-no-outer-border))
|
|
door-borderwidth 0)
|
|
(- door-borderwidth))
|
|
t)))
|
|
(setq n 1)))
|
|
(setq i (+ i 1)))
|
|
(apply bar-make blst))
|
|
(bar-make ))))
|
|
|
|
(defun door-mgr-show ()
|
|
(process-events)
|
|
(if (and door-mgr
|
|
(# 0 door-mgr)
|
|
(wob-is-valid (# 0 door-mgr)))
|
|
(with (wob (# 0 door-mgr)
|
|
xpos (# 1 door-mgr)
|
|
ypos (# 2 door-mgr))
|
|
(setq xpos (if (and xpos (< xpos 0))
|
|
(+ wob-x window-client-x window-client-borderwidth
|
|
(- screen-width) (width wob))
|
|
(+ wob-x window-client-x window-client-borderwidth)))
|
|
(setq ypos (if (and ypos (< ypos 0))
|
|
(+ wob-y window-client-y window-client-borderwidth
|
|
(- screen-height) (height wob))
|
|
(+ wob-y window-client-y window-client-borderwidth)))
|
|
(## 1 door-mgr xpos)
|
|
(## 2 door-mgr ypos)
|
|
(if (wob-is-valid wob-parent)
|
|
(delete-window wob-parent))))
|
|
(if (and door-mgr
|
|
(# 3 door-mgr)
|
|
(> (door-mgr-find-last (# 3 door-mgr)) 0))
|
|
(with (background door-background
|
|
foreground door-foreground
|
|
borderpixel door-foreground
|
|
bar-separator 0
|
|
plug-separator 0
|
|
borderwidth 0
|
|
direction vertical
|
|
reenter-on-opening ()
|
|
bar-list (door-mgr-construct-bar-list (# 3 door-mgr))
|
|
mgr (apply menu-make bar-list)
|
|
xpos (or (# 1 door-mgr) (# 1 (## 1 door-mgr door-mgr-xpos)))
|
|
ypos (or (# 2 door-mgr) (# 2 (## 2 door-mgr door-mgr-ypos)))
|
|
xpos (if (< xpos 0)
|
|
(- (+ screen-width xpos) (with (wob (menu-wob mgr))
|
|
(width wob)))
|
|
xpos)
|
|
ypos (if (< ypos 0)
|
|
(- (+ screen-height ypos) (with (wob (menu-wob mgr))
|
|
(height wob)))
|
|
ypos))
|
|
(## 0 door-mgr (menu-wob mgr))
|
|
(place-menu "door-mgr"
|
|
mgr
|
|
xpos ypos))))
|
|
|
|
(defun door-mgr-find-last (lst)
|
|
(with (i (- (length lst) 1))
|
|
(while (and (> i -1) (not (# i lst)))
|
|
(setq i (- i 1)))
|
|
(+ i 1)))
|
|
|
|
(defun door-mgr-remove-nil (lst)
|
|
(with (n 0
|
|
res ()
|
|
i 0)
|
|
(for e lst (if (not e) (setq n (+ n 1))))
|
|
(if (= n 0)
|
|
lst
|
|
(progn
|
|
(setq res (list-make (- (length lst) n)))
|
|
(for e lst (if e (progn (## i res e) (setq i (+ i 1)))))
|
|
res))))
|
|
|
|
(defun door-mgr-construct-bar-list (door-lst)
|
|
(with (num (door-mgr-find-last door-lst)
|
|
rows (if door-mgr-mdir-horiz
|
|
(+ (/ (- num 1) door-mgr-mdir-len) 1)
|
|
(min num door-mgr-mdir-len))
|
|
cols (if door-mgr-mdir-horiz
|
|
(min num door-mgr-mdir-len)
|
|
(+ (/ (- num 1) door-mgr-mdir-len) 1))
|
|
step (if door-mgr-mdir-horiz
|
|
1 door-mgr-mdir-len)
|
|
bstep (if door-mgr-mdir-horiz
|
|
door-mgr-mdir-len 1)
|
|
len (+ (* 2 rows) 1)
|
|
lst (list-make len)
|
|
i 1
|
|
n 0)
|
|
(if (and (> door-borderwidth 0)
|
|
(not door-mgr-no-outer-border))
|
|
(## 0 lst (door-make-hborder door-lst (- bstep) 0 step cols)))
|
|
(while (< i len)
|
|
(## i lst (apply bar-make (door-mgr-construct-plug-list door-lst n
|
|
step cols)))
|
|
(if (and (> door-borderwidth 0)
|
|
(not (and door-mgr-no-outer-border
|
|
(> (+ i 3) len))))
|
|
(## (+ i 1) lst (door-make-hborder door-lst n (+ n bstep)
|
|
step cols)))
|
|
(setq i (+ i 2))
|
|
(setq n (+ n bstep)))
|
|
(door-mgr-remove-nil lst)))
|
|
|
|
(defun door-mgr-construct-plug-list (door-lst n step num)
|
|
(with (len (+ (* 2 num) 1)
|
|
lst (list-make len)
|
|
i 1)
|
|
(if (and (> door-borderwidth 0)
|
|
(not door-mgr-no-outer-border))
|
|
(## 0 lst (door-make-vborder () (# n door-lst))))
|
|
(while (< i len)
|
|
(## i lst (with (door (# n door-lst))
|
|
(if door
|
|
(door-make-plug (# 0 door) (door-virt-coord n))
|
|
(door-make-space))))
|
|
(if (and (> door-borderwidth 0)
|
|
(not (and door-mgr-no-outer-border
|
|
(> (+ i 3) len))))
|
|
(## (+ i 1) lst (door-make-vborder (# n door-lst)
|
|
(if (< (+ i 2) len)
|
|
(# (+ n step) door-lst)))))
|
|
(setq i (+ i 2))
|
|
(setq n (+ n step)))
|
|
(door-mgr-remove-nil lst)))
|
|
|
|
(defun door-virt-coord (nr)
|
|
(if door-mgr-dir-horiz
|
|
(list (* screen-width (% nr door-mgr-dir-len))
|
|
(* screen-height (/ nr door-mgr-dir-len)))
|
|
(list (* screen-width (/ nr door-mgr-dir-len))
|
|
(* screen-height (% nr door-mgr-dir-len)))))
|
|
|
|
|
|
;; Door Manager Functionality
|
|
|
|
(defun get-door (nr)
|
|
(# nr (# 3 door-mgr)))
|
|
|
|
(defun set-door (nr ele)
|
|
(if (not (> (length (# 3 door-mgr)) nr))
|
|
(## 3 door-mgr (+ (# 3 door-mgr)
|
|
(list-make (- (+ 1 nr) (length (# 3 door-mgr)))))))
|
|
(## nr (# 3 door-mgr) ele))
|
|
|
|
(defun door-empty-space (virtcoord)
|
|
(with (left (+ (# 0 virtcoord) (# 0 virt-pos))
|
|
right (+ left screen-width)
|
|
top (+ (# 1 virtcoord) (# 1 virt-pos))
|
|
bottom (+ top screen-height))
|
|
(tag ret
|
|
(for wob (list-of-windows 'window 'mapped)
|
|
(if (not (virtual-nailed))
|
|
(with (midx (+ window-x (/ window-width 2))
|
|
midy (+ window-y (/ window-height 2)))
|
|
(if (and (> midx left)
|
|
(< midx right)
|
|
(> midy top)
|
|
(< midy bottom))
|
|
(exit ret ())))))
|
|
t)))
|
|
|
|
(defun door-find-index (ind free movable)
|
|
(if (and free movable)
|
|
(while (or (get-door ind) (not (door-empty-space (door-virt-coord ind))))
|
|
(setq ind (+ ind 1)))
|
|
movable
|
|
(while (get-door ind)
|
|
(setq ind (+ ind 1)))
|
|
free
|
|
(while (or (not (door-empty-space (door-virt-coord ind)))
|
|
(and (get-door ind)
|
|
(not (# 2 (get-door ind)))))
|
|
(setq ind (+ ind 1)))
|
|
(while (and (get-door ind)
|
|
(or (not (# 2 (get-door ind)))
|
|
(not (door-empty-space (door-virt-coord ind)))))
|
|
(setq ind (+ ind 1))))
|
|
ind)
|
|
|
|
(defun door-find-name (name)
|
|
(with (ind 0
|
|
ele (get-door ind)
|
|
len (length (# 3 door-mgr)))
|
|
(while (and (< ind len)
|
|
(not (= name (# 0 ele))))
|
|
(setq ind (+ 1 ind))
|
|
(setq ele (get-door ind)))
|
|
(if (< ind len)
|
|
ind
|
|
())))
|
|
|
|
(defun add-door args
|
|
(with (name (# 0 args)
|
|
startind (if (= (type (# 1 args)) 'number) (# 1 args) 0)
|
|
free (member 'free args)
|
|
movable (member 'movable args)
|
|
ind (door-find-index startind free movable)
|
|
virtpos (door-virt-coord ind)
|
|
ele (list name free movable))
|
|
(while (get-door ind)
|
|
(with (startind (+ 1 ind)
|
|
oldele (get-door ind)
|
|
newind (door-find-index startind (# 1 oldele) ()))
|
|
(set-door ind ele)
|
|
(setq ele oldele)
|
|
(setq ind newind)))
|
|
(set-door ind ele)
|
|
(door-mgr-show)
|
|
virtpos))
|
|
|
|
(defunq maybe-add-door args
|
|
(with (ind (door-find-name (eval (# 0 args))))
|
|
(if ind
|
|
(door-virt-coord ind)
|
|
(eval (+ (list 'add-door) args)))))
|
|
|
|
(defun goto-door (name)
|
|
(with (ind (door-find-name name)
|
|
pos (if ind (door-virt-coord ind)))
|
|
(if ind
|
|
(virtual-move-to (# 0 pos) (# 1 pos)))))
|
|
|
|
(defun remove-door (arg)
|
|
(with (ind ())
|
|
(if (= (type arg) 'string)
|
|
(: ind (door-find-name arg))
|
|
(= (type arg) 'number)
|
|
(: ind arg))
|
|
(if ind
|
|
(with (ele (get-door ind))
|
|
(set-door ind ())
|
|
(if (door-empty-space (door-virt-coord ind))
|
|
(with (newind (door-find-index (+ 1 ind) t ())
|
|
newele ())
|
|
(while (setq newele (get-door newind))
|
|
(set-door ind newele)
|
|
(setq ind newind)
|
|
(setq newind (door-find-index (+ 1 ind) t ())))
|
|
(set-door ind ())))))
|
|
(door-mgr-show)))
|
|
|
|
|
|
(defun clean-doors ()
|
|
(with (len (length (# 3 door-mgr))
|
|
i (- len 1))
|
|
(while (> i -1)
|
|
(if (and (get-door i)
|
|
(door-empty-space (door-virt-coord i))
|
|
(not (member (# 0 (get-door i)) initial-doors))
|
|
(not (= door-free-area-string (# 0 (get-door i)))))
|
|
(remove-door i))
|
|
(setq i (- i 1)))
|
|
(while (and (> door-auto-number 0)
|
|
(not (door-find-name (+ door-auto-string
|
|
(itoa door-auto-number)))))
|
|
(setq door-auto-number (- door-auto-number 1)))))
|
|
|
|
(defun restore-doors ()
|
|
(with (len (+ (length (# 3 door-mgr)) (* 2 door-mgr-dir-len))
|
|
i 0
|
|
old-dn door-auto-number)
|
|
(setq door-auto-number 0)
|
|
(while (< i len)
|
|
(if (and (not (get-door i))
|
|
(not (door-empty-space (door-virt-coord i))))
|
|
(progn
|
|
(setq door-auto-number (+ 1 door-auto-number))
|
|
(while (door-find-name (+ door-auto-string
|
|
(itoa door-auto-number)))
|
|
(setq door-auto-number (+ 1 door-auto-number)))
|
|
(add-door (+ door-auto-string (itoa door-auto-number)) i)))
|
|
(setq i (+ i 1)))
|
|
(if (> old-dn door-auto-number)
|
|
(setq door-auto-number old-dn))))
|
|
|
|
(defun fresh-door ()
|
|
(setq door-auto-number (+ door-auto-number 1))
|
|
(add-door (+ door-auto-string (itoa door-auto-number)) 'free))
|
|
|
|
(defun door-free-area-action ()
|
|
(with (pos (door-find-name door-free-area-string))
|
|
(if pos
|
|
(progn
|
|
(setq wob root-window)
|
|
(if door-free-area-cleans
|
|
(clean-doors))
|
|
(setq door-auto-number (+ door-auto-number 1))
|
|
(add-door (+ door-auto-string (itoa door-auto-number)) pos)))))
|
|
|
|
(defun make-free-area-door ()
|
|
(if (not (# (atom door-free-area-string) door-context))
|
|
(setq door-context (+ (list (atom door-free-area-string)
|
|
'(door-action '(door-free-area-action)
|
|
background (or door-free-area-color
|
|
door-background)))
|
|
door-context)))
|
|
(add-door (atom door-free-area-string) 'free 'movable))
|
|
|
|
(defun door-add-initial ()
|
|
(for door initial-doors
|
|
(if (= (type door) 'list)
|
|
(if (and (= (type (# 0 door)) 'atom)
|
|
(boundp (# 0 door))
|
|
(member (type (eval (# 0 door)))
|
|
'(subr fsubr expr fexpr)))
|
|
(eval door)
|
|
(apply add-door door))
|
|
(add-door door))))
|
|
|