1 ;; iswitch-window.jl (mmc's version) v1.5 -- incremental search for windows
5 ;; Copyright (C) 2000 Topi Paavola <tjp@iki.fi>
6 ;; Modifications and enhancements by Jens-Ulrik Petersen
7 ;; <jens-ulrik.petersen@nokia.com>
10 ;; Copyright (C) 2003-2005 Michal Maruska <mmc@maruska.dyndns.org>
11 ;; http://maruska.dyndns.org/comp/activity/darcs/sawfish/lisp/mmc/iswitch-window.jl
13 ;; This file is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
19 ;;; mmc: NEW FEATURES [14 giu 05]
21 ;; - current-search after i make an isearch, the list of matching window is rememebered, and can by x-cycled. (command `cycle-search-start')
22 ;; - display integrated w/ x-message: since 13/6/2005 W/O flickering!! (when you cycle the window list)
23 ;; - [18 dic 04] ADT to contain the restrictions, it's a (a)list
24 ;; then i can make some specific calls (with partial restriction)..
25 ;; iswitch-window-on-viewport for example .. [18 dic 04] in fact i can.
27 ;; call-for-next-key-events*
30 ;; [11 gen 06] serializing the query: as a list of nested conditions.
38 ;; Incremental window search, similar to iswitchb.el in emacs.
40 ;; Default keys (change in iswitch-get-window; ideally we should have an
43 ;; C-s,A-s,TAB find next matching window
44 ;; C-r,A-r,M-TAB find previous matching window
45 ;; C-g,ESC quit iswitch
46 ;; C-u clear input buffer
47 ;; backspace delete previous character
48 ;; C-z,A-z iconify window
49 ;; C-h,A-h shade window
52 ;; Other keys insert themselves. A-s (or H-s, depending on your
53 ;; modifiers) would be a good key to bind iswitch-window to; for example,
55 ;; (bind-keys global-keymap "A-s" 'iswitch-window)
57 ;; The iswitch-window-with function also does something to the current
58 ;; window. For example,
60 ;; (bind-keys global-keymap "A-s" '(iswitch-window-with
61 ;; (lambda (w) (iconify-window w))))
63 ;; would iconify the currently focused window and focus the newly
66 ;; This file is available at
67 ;; http://aton.co.jyu.fi/~tjp/sawfish/iswitch-window.jl
68 ;; and can also be found in the sawfish software map:
69 ;; http://adraken.themes.org/map.php
73 ;; * Added iswitch-show-window-class variable.
74 ;; * Fixed problem with undefined classes, thanks to Matt Tucker.
76 ;; * Added patches, A-z, A-h, reverse cycling (A-r) and
77 ;; iswitch-window-with from Jens.
78 ;; * TAB and M-TAB now do the same as A-s and A-r.
82 (define-structure mmc.iswitch-window
93 ;rep.mmsystem ;; not used here
102 sawfish.wm.misc ;grab!
106 sawfish.wm.util.window-order
109 sawfish.wm.util.display-window
110 sawfish.wm.state.iconify
111 sawfish.wm.state.shading
113 mmc.x-message ; i want colored lines!
117 ;sawfish.wm.commands.x-cycle
132 ;; application ; win-type role ?
135 (define-record-type :iswitch-criterion
136 (make-criterion) criterion?
137 (type type-of set-type!)
138 (model model-of model-y!))
140 ;; so i could use a 2-list ( (type model) .....) !
141 (defvar current-criterion '()
142 "keep the structured contstraints of the last iswitch.")
144 ;;; my fix-search hack .. todo: replay the current-criterion to avoid killed windows
145 (defvar current-search nil
146 "a list of windows, last selected w/ some selecting tool: iswitch-window, wid ..., used by x-cycle")
151 (defvar iswitch-show-window-class nil
152 "Display WM_CLASS of windows in the iswitch menu.")
154 ;;(setq iswitch-show-window-class #t)
160 ;; Use the following to customize the look of the menu.
162 (defvar iswitch-font default-font
163 "Font for iswitch-window popup")
165 (defvar iswitch-background-color "white"
166 "Background color for iswitch-window popup")
168 (defvar iswitch-foreground-color "black"
169 "Foreground color for iswitch-window popup")
172 (define iswitch-visibility-alist
175 (partially-obscured . "%")
176 (fully-obscured . "@"))
179 (partially-obscured . "po")
180 (fully-obscured . "fo"))
183 (define iswitch-viewport-direction-alist
193 ;; the SGN function -1 0 1
202 (define (iswitch-viewport-direction wv cv)
207 (cdr (assoc (cons (sign (- wvx cvx)) (sign (- wvy cvy)))
208 iswitch-viewport-direction-alist))))
212 (define (pad-to string needed-len)
213 (let ((len (length string)))
215 ((= len needed-len) string)
217 (concat string (make-string (- needed-len len) " ")))
219 (substring string 0 needed-len)))))
221 ;(pad-to "michal" 13)
225 (define (iswitch-window-line w)
228 (cond ((window-get w 'iconified)
230 ((window-get w 'sticky)
232 ((not (window-in-workspace-p w current-workspace))
234 ((window-outside-viewport-p w)
235 (iswitch-viewport-direction (window-viewport w) (screen-viewport)))
236 ((window-get w 'shaded)
238 ((cdr (assoc (window-visibility w)
239 iswitch-visibility-alist))))
242 (if iswitch-show-window-class
243 (let ((class-name (get-x-text-property w 'WM_CLASS)))
245 (pad-to ;fixme: make it a minimum but w/o maximum !!!
254 (define (dispatch-condition-format condition)
255 ;; condition is a list
256 (let ((type (condition-type condition)))
260 (define iswitch-display-window #f "x-message ")
263 ;; format user input and window list for display-message
264 (define (iswitch-display criterions input wlist)
265 ;(DB "iswitch-display: we have already a window: %s\n" (if iswitch-display-window "yes" "no"))
266 ;(DB "%s->%s\n" criterions (mapconcat dispatch-condition-format criterions " : "))
269 ;; (if iswitch-display-window (x-message-hide iswitch-display-window))
271 (setq iswitch-display-window
276 '(border-color . "red")
278 '(foreground . "yellow")
279 (mapconcat dispatch-condition-format criterions " : ")
280 '(foreground . "red")
282 '(foreground . "green")
283 (format #f "total: %d" (length wlist))
284 '(foreground . "gray")
285 ;(mapconcat dispatch-condition-format criterions " : ")
287 (mapcar iswitch-window-line wlist))
289 '((background . "black")
290 (foreground . "gray"))
291 (if iswitch-display-window
292 `(#:mwindow ,iswitch-display-window)
301 ;; find next window matching input string
302 (define (iswitch-rotate-to-next-match input wlist #!optional previous) ; fixme
305 (catch 'iswitch-found
307 (when (string-match input (window-name w) 0 t)
308 (throw 'iswitch-found w)))
310 (reverse (cdr wlist))
316 (define (iswitch-update-match string wlist)
317 "return the WLIST limited to windows w/ name which matches the INPUT"
318 ;;(message (format #f "match: 1: %s" (car input)))
320 (let ((name (window-name w)))
321 (string-match string name 0 'ignore-case)))
324 (define (iswitch-update-by-name names wlist)
327 (string-match-string-list-p names (window-name w)))
330 ; we need functions !!
332 (define (iswitch-update-match-class input wlist)
333 "return the WLIST limited to windows whose class (name) matches the input"
334 ;;(message (format #f "match: 1: %s" (car input)))
336 (let ((class (window-class w)))
337 (string-match-string-list-p input class)))
340 (define (iswitch-update-workspace wlist workspace)
341 "limit WLIST to those (windows) which are/are NOT on the current ws."
342 (DB "iswitch-update-workspace: %s\n" workspace)
344 (if (consp workspace) ;; (- . 1)
346 (not (window-in-workspace-p w (cdr workspace))))
349 (window-in-workspace-p w workspace)))))
353 (not (window-iconified-p w))))
358 (define (iswitch-update-class wlist types)
359 "the class of window must be one of TYPES (a list of strings)"
361 ;(string= type (window-class w)))
362 (member (window-class w) types))
366 (define (iswitch-constraint-by wlist predicate)
371 (define (iswitch-update-viewport wlist info) ;fixme: could it be a boolean value? and i want out of this viewport ??
372 (declare (unused info))
373 "limit WLIST to those (windows) which are on the current ws & vieport. sorry, we need to test ws too."
374 (let ((workspace current-workspace))
377 (not (window-iconified-p w))
378 (not (window-outside-viewport-p w))
379 (window-in-workspace-p w workspace)))
383 (define (x-property= window prop-name model)
384 "is the PROP-NAME X property on WINDOW a string MODEL?"
385 (let ((prop (get-x-text-property window prop-name)))
388 (string= (aref prop 0) model))))
390 (define (windows-on-host wlist hostname)
391 "use standard & SF specific criterions to find windows `running' on the host HOSTNAME"
395 (x-property= window 'WM_CLIENT_MACHINE hostname)
396 (x-property= window 'sf_host hostname)))
399 (define (condition-type condition)
403 (define (dispatch-condition wlist condition)
404 "interpret the (car CONDITION), and dispatch/apply the right function w/ the the (cdr codition) on WLIST. Return the result."
405 ;; condition is a list
406 (let ((type (condition-type condition)))
409 (iswitch-update-by-name (cdr condition) wlist) ;fixme! order
412 (iswitch-update-class wlist (cdr condition)))
414 (windows-on-host wlist (cadr condition)))
422 (iswitch-update-workspace wlist (cadr condition))) ;fixme!
425 (iswitch-update-viewport wlist (cadr condition))
429 (iswitch-constraint-by wlist (cadr condition)))
432 ;(dispatch-condition (managed-windows) (list 'class "Emacs"))
433 ;(dispatch-condition (managed-windows) (list 'workspace 0))
436 (define (iswitch-add-condition wlist condition)
437 (setq current-criterion (cons condition current-criterion))
438 (dispatch-condition wlist condition))
440 (define (replay-criterions criterion-list #!optional wlist) ;todo: take an optional wlist argument
441 "apply the CRITERION-LIST to WLIST (by default `window-order'). See `dispatch-condition' for the list of supported criterions."
443 (setq wlist (window-order nil t t))) ;; (managed-windows)
446 (setq wlist (dispatch-condition wlist condition)))
452 (defmacro iswitch-add-condition! (wlist condition)
455 (iswitch-add-condition ,wlist ,condition)))
459 (define (iswitch-get-windows #!optional criterions)
460 "Let user pick a window with incremental search and return that window."
462 (setq criterions '()))
463 (call-with-keyboard-grabbed
465 (let ((display-timer #f)) ;mmc: this is when i want to press more keys at once, skipping the initial all-windows display
466 ;; fixme: make it a fluid!
467 (setq current-criterion criterions)
469 (let* ((input "") ; current string to be matched
470 ;(constraints ()) ; other (non textual) constraints (workspace, viewport, state, ...)
472 (replay-criterions current-criterion))
473 (focused-window (car init-wlist))
476 wlist ; matching windows ?
479 (if (< (length wlist) 2)
480 ;; bug: this will raise the window too! But C code wil
481 ;; then focus & raise (possibly) another window!
482 (display-window (car wlist))) ;-without-focusing
483 (iswitch-display current-criterion input wlist))))
484 ;; put the current at the end:
485 (setq init-wlist (append (cdr init-wlist) (list focused-window))
488 ;;; how we make a recursive event loop:
490 ;; we tell the C core, that the keymap is void.
491 ;; then we get all the keys via `unbound-key-hook'
492 ;; and can invoke ourselves the functions.
494 ;; we control allow-events, ungrab-keyboard through grab-counter
497 (call-for-next-key-events
501 (set-timer display-timer)
502 (setq display-timer (make-timer display-function 0 100))) ;we should see other keys first !!
503 (display-function)) ;initial list
504 (setq use-timer #t)) ; hm??
507 (let ((key (car event-info))
508 (event-string (cdr event-info)))
510 (cond ((or (equal key "A-g")
512 (equal key "ESC")) ;fixme: we just lost the `current-criterion'
514 (throw 'exit-iswitch nil))
516 ((or (equal key "C-u")
521 wlist (replay-criterions current-criterion)))
522 ;;(iswitch-update-match (cons input constraints) init-wlist)))
524 ((or (equal key "BS")
526 (if (> (length input) 0)
528 (setq input (substring input 0 (1- (length input))))
529 (setq wlist (replay-criterions current-criterion))
530 (iswitch-update-match input init-wlist))
532 (setq current-criterion (safe-cdr current-criterion))
533 (setq wlist (replay-criterions current-criterion)) ;init-wlist is recomputed! that's good.
536 ;; should be a common ...
537 ; (setq wlist (iswitch-update-match (cons input constraints) init-wlist)))
539 (iswitch-add-condition! wlist '(class "Emacs")))
543 ;; do i want alist ??
544 ;; should be a common ...
545 ((or (equal key "C-w") ; limit to the current workspace:
547 ;; should be a common ...
548 (iswitch-add-condition! wlist (list 'workspace current-workspace)))
551 ;(setq wlist (iswitch-update-class wlist '("Emacs")))
553 (iswitch-add-condition
554 (iswitch-add-condition wlist '(class "Emacs" "xemacs"))
559 (iswitch-add-condition! wlist '(class "XTerm")))
562 ; (setq wlist (iswitch-update-class wlist '("galeon_browser"))))
565 (iswitch-add-condition! wlist '(class "gauche"))
566 ;(setq wlist (iswitch-update-class wlist '("gauche")))
570 (iswitch-add-condition! wlist `(predicate ,window-iconified-p)))
573 (setq wlist (iswitch-update-class wlist '("X-Chat"))))
578 ;;(setq wlist (iswitch-update-class wlist '("X-Chat")))
583 ;(setq wlist (iswitch-update-class wlist '("X-Chat")))
589 (iswitch-add-condition! wlist '(class "XTerm"))
590 (iswitch-add-condition! wlist '(name "Elinks")))
592 ;;"navigator:browser"
595 (iswitch-add-condition!
601 "MozillaFirebird-bin"
606 ((equal key "C-v") ; limit to the current viewport
608 (iswitch-add-condition!
610 `(viewport ,current-workspace)))
613 ((equal key "C-o") ; limit to the current viewport
615 (iswitch-add-condition!
617 `(workspace (not . ,current-workspace))))
621 (setq current-search wlist))
630 (setq wlist (iswitch-rotate-to-next-match input wlist)))
631 ((or (equal key "C-r")
638 (setq wlist (iswitch-rotate-to-next-match input wlist t)))
640 ((or (equal key "RET")
643 (unless (string= input "")
644 (push! current-criterion `(name ,input)))
645 (setq current-search wlist)
646 (throw 'exit-iswitch wlist))
648 ((or (equal key "C-j")) ; push this constraint
649 (iswitch-add-condition! wlist `(name ,input))
652 ((or (equal key "M-h")) ; push this constraint
653 ;(get-x-text-property (input-focus) 'WM_CLIENT_MACHINE)
655 (delete-timer display-timer))
656 (let ((host (prompt-for-host)))
657 ;(display-message host)
658 (iswitch-add-condition! wlist `(host ,host))))
661 ;;; These don't `modify' the wlist:
663 ;; Some handy ops, once we are there why not to ... toggle some
664 ((or (equal key "C-z")
666 (let ((w (car wlist)))
667 (if (window-get w 'iconified)
669 (iconify-window w))))
671 ((or ;(equal key "C-h")
674 (toggle-window-shaded (car wlist)))
680 ;; append ... `chars' only !
681 ((or ;(equal key "SPC")
682 (= 1 (length event-string))) ; sawfish.wm.events
683 (setq input (concat input event-string)
684 wlist (iswitch-update-match input wlist))))
686 (when (= 1 (length wlist))
688 ;(throw 'exit-iswitch wlist)
689 (display-window (car wlist))))))))
692 (display-message nil)
693 (x-message-hide iswitch-display-window)
695 (delete-timer display-timer)))))))
698 ;; Enter iswitch, but at first limit by host:
699 (define (iswitch-start-host)
700 (let ((host (prompt-for-host)))
702 (safe-car (iswitch-get-windows
703 ;(display-message host)
707 (define-command 'iswitch-start-host iswitch-start-host)
709 ; (ungrab-keyboard-soft)
710 (define (iswitch-get-window)
711 (safe-car (iswitch-get-windows '())))
714 (define (iswitch-window)
715 "Pick a window by incremental search and select it." ;(interactive)
716 (display-window (iswitch-get-window)))
721 ;; maybe it's useful to just fix a search/set of windows ?
722 ;; Note, that the set-of-windows is not updated!!!
723 (define (make-search)
724 (setq current-search (iswitch-get-windows '())))
726 ;; But i would like to have such named searches ??
731 (define-command 'make-search make-search) ; Is it used?
733 (define-command 'iswitch-window iswitch-window)
735 (define-command 'iswitch-window-continue
738 (safe-car (iswitch-get-windows current-criterion)))))
741 (define-command 'iswitch-window-here
744 (safe-car (iswitch-get-windows `((workspace ,current-workspace)))))))
746 ;; ??? this should be an interactive #:spec !
747 (define (iswitch-window-with act)
748 "Pick a window by incremental search, select it and ACT on previous."
750 (let ((old (car (window-order)))
751 (new (iswitch-get-window)))
753 (unless (or (eq new old)
754 (window-get old 'sticky)
755 (window-outside-viewport-p new))
757 (display-window new)))))
759 ;; todo: colored display.
760 ;(window-class (get-window-by-name-re "X-Chat"))