#!/bin/sh
exec guile-gnome-0 -e main -s $0 "$@"
!#

;;;; keywise.scm: Keyboard Window Selector (version 0.0.3)
;;;; Hacker-friendly window selector for Metacity.

;;;; FEATURES
;;;;  * bind key to cycle windows in group of classes
;;;;  * window list popup, with workspace and iconization state annotations
;;;;    optionally persistant and sticky.
;;;;  * dynamically bind key (C-[DIGIT]) to focus specific window from
;;;;    window list popup
;;;;
;;;; The default settings remaps M-TAB, binds KP_1 to cycle Emacs
;;;; windows, KP_2 cycles shells, KP_3 viewers and KP_4 Browser
;;;; windows.

;;;; BUGS addressed
;;;; * bugzilla.gnome.org/show_bug.cgi?id=86390
;;;;     allow selection of icons in alt-tab popup via mouse
;;;; * bugzilla.gnome.org/show_bug.cgi?id=97725
;;;;     allow dynamic mapping of windows to keys in alt-tab popup
;;;; * bugzilla.gnome.org/show_bug.cgi?id=102656
;;;;     make a 'sticky' alt-tab popup
;;;; * bugzilla.gnome.org/show_bug.cgi?id=136666
;;;;     minimized windows in alt-tab list should be bracketed/dimmed
;;;; * bugzilla.gnome.org/show_bug.cgi?id=140925
;;;;     windowmaker-like window list, cycle class

;;;; ChangeLog
;;;;
;;;; 2004-10-24  Jan Nieuwenhuizen  <janneke@gnu.org>
;;;;
;;;;	* Version 0.0.3
;;;;	* Metacity key bindings.
;;;;	* Add cycle class group, with key bindings.
;;;;    * Dynamically bind keys (C-[DIGIT]) to windows.
;;;;	
;;;; 2004-06-04  Jan Nieuwenhuizen  <janneke@gnu.org>
;;;;	
;;;;	* Version 0.0.2
;;;;    * Rewrite in Scheme.
;;;;
;;;; 2004-05-12  Jan Nieuwenhuizen  <janneke@gnu.org>
;;;;
;;;;	* Version 0.0.1
;;;;	* My first gtk+ app.

;;;; TODO
;;;;   * dynamically bind shortcuts for cycle-class
;;;;   * show all shortcut bindings in window-list
;;;;   * sort classes, windows according to age?
;;;;   * libwnck fixes/features
;;;;      - warp pointer to selected window
;;;;      - show workspace name when selecting workspace
;;;;   * fork gtk-main for client mode
;;;;   * ???
;;;;   * profit

;;;; COPYRIGHT AND LICENCE
;;;;   Copyright (C) 2004--2007 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; 
;;;;   This program is free software; you can redistribute it and/or modify
;;;;   it under the terms of the GNU General Public License as published by
;;;;   the Free Software Foundation; either version 2 of the License, or
;;;;   (at your option) any later version.
;;;; 
;;;;   This program is distributed in the hope that it will be useful,
;;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;   GNU General Public License for more details.
;;;; 
;;;;   You should have received a copy of the GNU General Public License
;;;;   along with this program; if not, write to the Free Software
;;;;   Foundation, Inc., 59 Temple Place, Suite 330,
;;;;   Boston, MA 02111-1307, USA.


;;; Begin Customisation.
;;;
;;; If you add similar define's to your ~/.keywise/custom.scm,
;;; those will be used instead.
;;;
;;; Define default application class name grouping.
(define CLASS-NAME-GROUPS
  '((1 . ("emacs"))
    (2 . ("gnome-terminal" "terminal" "xterm" "rxvt"))
    (3 . ("evince" "xdvi" "xpdf" "gv" "ggv" "gpdf"))
    (4 . ("mozilla" "galeon" "firefox" "epiphany"))
    (5 . ("eog" "gimp" "display"))
    (0 . ("ungrouped"))))
;;;
;;; Define default group cycling shortcuts.
(define METACITY-KEYBINDING-ALIST
  '(("<Alt>Tab" . (popup-window-list))
    ("KP_1" . (cycle-class 1))
    ("KP_2" . (cycle-class 2))
    ("KP_3" . (cycle-class 3))
    ("KP_4" . (cycle-class 4))
    ("KP_5" . (cycle-class 5))))
;;; End customisation.


(define PROGRAM-NAME "keywise")
(define PROGRAM-VERSION "0.0.4")
(define RCDIR (string-append (getenv "HOME") "/.keywise"))
(define BINDINGS-FIFO (string-append RCDIR "/bindings"))
(define CUSTOM (string-append RCDIR "/custom.scm"))

(use-modules (ice-9 format)
	     (ice-9 getopt-long)
	     (ice-9 regex)
	     (srfi srfi-1)
	     (srfi srfi-2)
	     (srfi srfi-8)
	     (srfi srfi-13))

;; Hmm
(define filter-out remove)

(use-modules (gnome gtk)
	     (gnome gtk gdk-event)
             (gnome gw wnck)
	     (gnome gw gtk))

(catch #t (use-modules (ice-9 readline)) (lambda x #f))

(define (assoc-get-default key alist default)
  (let ((entry (assoc key alist)))
    (if entry (cdr entry) default)))

(define (debug string . rest) #f)

(define (next-in-list x lst)
  (if (null? lst)
      #f
      (let ((cur (member x lst)))
	(car (if (and cur (pair? (cdr cur))) (cdr cur) lst)))))

(define real-system system)
(define (system x)
  (debug "invoking: ~S\n" x)
  (real-system x))

(define (stderr string . rest)
  (apply format (cons (current-error-port) (cons string rest)))
  (force-output (current-error-port))
  #t)

(define (x-string-prefix-ci? a b)
  ;;(debug "STRING-PREFIX: ~S, ~S\n" a b)
  (string-prefix-ci? a b))

(define (string-match-any string lst)
  (define (my-or a b)
    (or a b))
  (reduce my-or #f (map (lambda (x) (x-string-prefix-ci? x string)) lst)))

;;;
(define-method (get-create-accel-group (widget <gtk-widget>))
  (let ((group (get-accel-group widget)))
    (if group
	group
	(let* ((accel-group (make <gtk-accel-group>))
	       ;; FIXME: wrap gtk-item-factory
	       (item-factory (make <gtk-item-factory>)))
	  (construct item-factory 'menu-bar "<main>" accel-group)
	  accel-group))))

;; There seems to be no maximum, yay!
;;(define METACITY-MAX-BINDINGS 12)
(define METACITY-MAX-BINDINGS 100)
(define BINDING-COUNT 0)

(define (metacity-bind-key key-name)
  (define (gconf key value)
    (system (format #f "gconftool-2 --set ~s --type=string ~S" key value)))

  (if (< BINDING-COUNT METACITY-MAX-BINDINGS)
      (let ((pipe-command
	     (format #f "sh -c 'echo ~S > ~S'" key-name BINDINGS-FIFO))
	(command-key
	 (format #f "/apps/metacity/keybinding_commands/command_~d"
		 (1+ BINDING-COUNT)))
	(run-key
	 (format #f "/apps/metacity/global_keybindings/run_command_~d"
		  (1+ BINDING-COUNT))))

	(gconf command-key pipe-command)
	(gconf run-key key-name)
	(set! BINDING-COUNT (1+ BINDING-COUNT)))
      (not (stderr "too many bindings: ~d\n" BINDING-COUNT))))

(define-method (class-group-number (window <wnck-window>))
  (let ((name (group-name window)))
    (let loop ((lst CLASS-NAME-GROUPS))
      (if (pair? lst)
	  (if (string-match-any name (cdar lst))
	      (1- (caar lst))
	      (loop (cdr lst)))
	  9))))
	 
(define-class <keywise-app> ()
  (menu #:init-value #f #:accessor get-menu #:init-keyword #:menu)
  (accels #:init-value (make-hash-table 31) #:accessor get-accels)
  (windows #:init-value (make-hash-table 31) #:accessor get-windows)
  (selects #:init-value (make-hash-table 31) #:accessor get-selects)
  (grouped? #:init-value #t)
  (keep-open? #:init-value #f))

(define WINDOW-SHORTCUTS
  (list gdk:0 gdk:1 gdk:2 gdk:3 gdk:4 gdk:5 gdk:6 gdk:7 gdk:8 gdk:9))

(define (set-shortcut keywise-app shortcut window)
  (debug "SET-SHORTCUT\n")
  (let* ((metacity-key-name
	  (format #f "<Control>~d" (- 10 (length shortcut))))
	 (bound (hash-ref (get-selects keywise-app) metacity-key-name #f)))
    (if (and (not bound)
	     (metacity-bind-key metacity-key-name))
	(begin
	  (debug "window: ~S ~S\n" window (get-name window))
	  (debug "SELECTOR: ~S -> ~S\n"
		 metacity-key-name (get-name window))
	  
	  (hash-set! (get-accels keywise-app) window shortcut)
	  (hash-set! (get-selects keywise-app) metacity-key-name window)))))

(define-method (is-prelight (menu-item <gtk-menu-item>))
  (equal? (genum->symbol (get-state menu-item)) 'prelight))

(define-method (get-focus (menu <gtk-menu>))
  (let loop ((children (get-children menu)))
    (if (pair? children)
	(if (is-prelight (car children))
	    (car children)
	    (loop (cdr children)))
	#f)))

(define (key-press-event keywise-app widget event)
  (let* ((keyval (gdk-event-key:keyval event))
	 (mods (gdk-event-key:modifiers event))
	 (shortcut (member keyval WINDOW-SHORTCUTS)))
    (debug "keypress: ~S ~S ~S\n" mods keyval shortcut)
    (cond ((and (or (eq? keyval gdk:q)
		    (eq? keyval gdk:w))
		(equal? mods '(control-mask mod2-mask)))
	   (gtk-main-quit))
	  ((and (equal? mods '(control-mask mod2-mask))
		shortcut)
	   (let* ((focused (get-focus widget))
		  (window (hash-ref (get-windows keywise-app) focused #f)))
	     (debug "focused: ~S\n" focused)
	     (debug "window: ~S\n" window)
	     (if window
		 (set-shortcut keywise-app shortcut window))
	     (if (not (slot-ref keywise-app 'keep-open?))
		       (popdown (get-menu keywise-app))))))
    #f))

(define-method (get-screen (keywise-app <keywise-app>))
  (let* ((widget (get-menu keywise-app))
	 (screen (get-screen widget))
	 (number (get-number screen)))
    (wnck-screen-get number)))

(define-method (get-active-workspace (keywise-app <keywise-app>))
  (let ((screen (get-screen keywise-app)))
    (get-active-workspace screen)))

(define-method (set-window-icon (menu-item <gtk-widget>) window)

  (let* ((window-icon (get-icon window))
	 ;; FIXME: wrap gtk-icon-size-lookup
	 ;; gtk-icon-size-lookup (GTK-ICON-SIZE-MENU, NULL, &icon-size);
	 (icon-size 25)
	 (pixbuf (if window-icon window-icon (get-default-window-icon)))
	 (width (get-width pixbuf))
	 (height (get-height pixbuf))
	 (image (make <gtk-image>)))

    (set-from-pixbuf
     image
     (if (or (> width icon-size) (> height icon-size))
	 (scale-simple pixbuf (inexact->exact (round (* 0.5 width)))
		       (inexact->exact (round (* 0.5 height))) 'bilinear)
	 pixbuf))
    (set-image menu-item image)
    (show image)))

(define (-menu-add-window menu window label)
  (let* ((menu-item (gtk-image-menu-item-new-with-mnemonic label)))
    (set-window-icon menu-item window)
    (append menu menu-item)
    (show menu-item)
;;NOTIFY: "_4 et - Mozilla Firefox [twee]" (#<<gtk-image-menu-item> 2b689a842ea0>, #<gvalue <gtk-state-type> 2b68a4817f50 (prelight GTK_STATE_PRELIGHT 2)>)
;;NOTIFY: "_0 Pidgin" (#<<gtk-image-menu-item> 2b689a841d80>, #<gvalue <gtk-state-type> 2b68a481d7e0 (normal GTK_STATE_NORMAL 0)>)
    (connect menu-item 'state-changed (lambda (self event)
					(debug "NOTIFY: ~S (~S, ~S)\n" label self event)
	       #f))
    ;; FIXME: wraper
    ;;(set-data menu-item "window" #f)
    ;;(gobject-set-data menu-item "window" #f)
    menu-item))

(define-method (select (window <wnck-window>))
  (let ((workspace (get-workspace window)))
    (if workspace
	(begin
	  (activate workspace)
	  (if (is-minimized window)
	      (unminimize window))
	  (activate window
		    ;; FIXME: where to get X timestamp?
		    ;;(+ (current-time) 10))))))
		    (gtk-get-current-event-time)
		    ;;0
		    )))))

(define-method (get-basename (window <wnck-window>))
  (let* ((group (get-class-group window))
	 (group-name (get-name group))
	 (name (get-name window))
	 (group-length (if group-name (string-length group-name) 0))
	 (name-length (string-length name)))
    (if (and name group-name (> group-length 0) (> name-length group-length))
	(substring name group-length name-length)
	(if name name
	    (if group-name group-name
		"Unknown Window")))))

(define-method (make-label (window <wnck-window>) i strip-group-name? active)
  (let* ((basename (get-basename window))
	 (group-name (group-name window))
	 (strip? (or strip-group-name? (equal? basename group-name)))
	 (sep (if strip? "" " - "))
	 (group (if strip? "" group-name))
	 (workspace (get-workspace window))
	 (workspace-name (if workspace (get-name workspace) ""))
	 (work (if (eq? workspace active)
		   "" (format #f " [~a]" workspace-name)))
	 (raw-label (format #f "_~a ~a~a~a~a" i group sep basename work))
	 (raw-length (string-length raw-label))
	 (label (if (> raw-length 30)
		    (format #f "_~a ~a~a~a~a" i group sep
			    (string-append
			     (substring basename 0
					(- (string-length basename)
					   (- raw-length 30)))
			     "..")
			work)
		raw-label)))
    (if (is-minimized window)
	(format #f "[~a]" label)
	label)))

(define-method (add-window (keywise-app <keywise-app>)
			   menu window i strip-group-name? active)
  (let* ((label (make-label window i strip-group-name? active))
	 (menu-item (-menu-add-window menu window label)))
    (if window
	(begin
	  (connect menu-item 'activate (lambda (x) (select window)))
	  (hash-set! (get-windows keywise-app) menu-item window)))
    menu-item))

(define (group-by-class-group lst)
  (let ((grouped (make-vector (max 10 (length CLASS-NAME-GROUPS)) '())))
    (for-each
     (lambda (x) (let ((n (class-group-number x)))
		   (vector-set! grouped n (cons x (vector-ref grouped n)))))
     lst)
    (vector->list grouped)))

(define-method (menu-keypad (keywise-app <keywise-app>))
  (for-each (lambda (x) (remove (get-menu keywise-app) x))
	    (get-children (get-menu keywise-app)))
  (set-tearoff-state (get-menu keywise-app) (slot-ref keywise-app 'keep-open?))
  (stick (get-toplevel (get-menu keywise-app)))
  (set! (get-windows keywise-app) (make-hash-table 31))
  (let ((menu (get-menu keywise-app))
	(windows (if (slot-ref keywise-app 'grouped?)
		     (group-by-class-group (managed-windows))
		     (map list (managed-windows))))
	(workspace (get-active-workspace keywise-app))
	(i 0))
    (connect menu 'key-press-event
	     (lambda (w e) (key-press-event keywise-app w e)))
    (for-each
     (lambda (x)
       (if (pair? x)
	   (let* ((window (car x))
		  (name (group-name window))
		  (accel (modulo (1+ i) 10)))
	     (if (= (length x) 1)
		 (add-window keywise-app (get-menu keywise-app)
			     window accel 0 workspace)
		 (let* ((label (format #f "_~a ~a" accel name))
			(menu-item (-menu-add-window
				    (get-menu keywise-app) window label))
			(sub-menu (make <gtk-menu>))
			(j 0))
		   (connect sub-menu 'key-press-event
		   	    (lambda (w e) (key-press-event keywise-app w e)))
		   (set-submenu menu-item sub-menu)
		   (for-each
		    (lambda (y)
		      (let ((accel (modulo (1+ j) 10)))
			(add-window keywise-app sub-menu y accel 1 workspace)
			(set! j (1+ j))))
		    x)))))
       (set! i (1+ i)))
     windows)
    
    (let ((children (get-children (get-menu keywise-app))))
      (not (null? children)))))

    ;; (define-method popup
    ;;   (of-object "GtkMenu")
    ;;   (c-name "gtk_menu_popup")
    ;;   (return-type "none")
    ;;   (parameters
    ;;     '("GtkWidget*" "parent_menu_shell")
    ;;     '("GtkWidget*" "parent_menu_item")
    ;;     '("GtkMenuPositionFunc" "func")
    ;;     '("gpointer" "data")
    ;;     '("guint" "button")
    ;;     '("guint32" "activate_time")
    ;;   )
    ;; )
(define-method (popup-menu (keywise-app <keywise-app>))
  (let ((menu? (menu-keypad keywise-app)))
    ;; FIXME
    ;;(popup (get-menu keywise-app) #f #f
    (gtk-menu-popup (get-menu keywise-app) #f #f
	   ;; FIXME: wrap gtk_menu_popup
	   ;;(lambda (x) (menu-get-position-menu x keywise-app))
	   #f #f 0 0)))

(define-method (group-name (window <wnck-window>))
  (get-name (get-class-group window)))

(define-method (window-name (window <wnck-window>))
  (get-name window))

(define popup-window-list #f)
(define cycle-class #f)
(define wnck-screen #f)

(define (all-windows)
  (define (window-compare a b)
    (string<? (format #f "~S" a) (format #f "~S" b)))
  (sort (get-windows (wnck-screen)) window-compare))
	       
(define (managed-windows)
  (filter-out is-skip-tasklist (all-windows)))

(define (active-window)
  (get-active-window (wnck-screen)))

(define (windows-of-name lst)
  ;;(debug "WINDOWS: ~S\n" (map (lambda (x) (format #f "~S:~S" (group-name x) (window-name x))) (all-windows)))
  (filter (lambda (x) (string-match-any (group-name x) lst)) (all-windows)))

(define-method (-cycle-class (keywise-app <keywise-app>) number)
  (let* ((names (assoc-get-default number CLASS-NAME-GROUPS '("")))
	 (windows (windows-of-name names))
	 (active (active-window))
	 (next (next-in-list active windows)))
    ;;(debug "LOOKING FOR: ~S\n" names)
    (if active
	(debug "ACTIVE: ~S\n" (window-name (active-window))))
    (if next
	(begin
	  (debug "NEXT (activating): ~S\n" next)
	  (debug "NEXT (activating): ~S\n" (window-name next))
	  (select next))
	(debug "NOTHING NEXT: ~S\n" windows ))))

(define (show-version port)
  (display (string-append PROGRAM-NAME " " PROGRAM-VERSION "\n") port))

(define (show-help)
  (format (current-output-port) "Keyboard Window Selector

Usage: keywise [OPTION]...

Options:
  -c,--client        client mode
  -d,--debug         debug mode
  -f,--flat          present flat window list menu
  -h,--help          show this help
  -k,--keep-open     keep sticky window list open
  -v,--version       show version
  -x,--no-custom     do not attempt to load custom.scm
"))

(define (options keywise-app args)
  (let ((options (getopt-long args
			      '((client (single-char #\c))
				(debug (single-char #\d))
				(flat (single-char #\f))
				(help (single-char #\h))
				(keep-open (single-char #\k))
				(version (single-char #\v))
				(no-custom (single-char #\x))))))
    (if (assq 'debug options)
	(begin
	  (debug-enable 'debug)
	  (debug-enable 'backtrace)
	  (set! debug stderr)))
    (if (assq 'flat options)
	(slot-set! keywise-app 'grouped? #f))
    (if (assq 'keep-open options)
	(slot-set! keywise-app 'keep-open? #t))
    (if (assq 'help options)
	(begin (show-version (current-output-port)) (show-help) (exit 0)))
    (if (assq 'version options)
	(begin (show-version (current-output-port)) (exit 0)))

    (if (and (not (assq 'no-custom options))
	     (access? CUSTOM R_OK))
	(primitive-load CUSTOM))

    (show-version (current-error-port))

    (if (assq 'client options)
	(begin (client) (exit 0)))))

(define (client)
  (catch #t (lambda () (activate-readline)) (lambda x #f))
  (set-repl-prompt! "keywise> ")
  (scm-style-repl))

(define-method (init-ipc (keywise-app <keywise-app>))

  (define (bindings-callback source condition)
    (debug "bindings-callback\n")
    (receive (status line len term) (g-io-channel-read-line source)
	     (let ((string (substring line 0 (- (string-length line) 1))))
      (debug "~S\n" string)
      (if (equal? string "client") (client))
      (if (equal? string "exit") (gtk-main-quit))
      ;; UGH?
      (let ((func (assoc-get-default string METACITY-KEYBINDING-ALIST #f)))
	(debug "func: ~S\n" func)
	(if func (primitive-eval func)))
      (let ((window (hash-ref (get-selects keywise-app) string #f)))
	(debug "window: ~S\n" window)
	(if window (select window)))
      #t)))

  (if (not (access? BINDINGS-FIFO F_OK))
      (begin
	(if (not (access? RCDIR F_OK))
	    (mkdir RCDIR #o700))
	(mknod BINDINGS-FIFO 'fifo #o600 0)))
  (let ((channel (g-io-channel-new-file BINDINGS-FIFO)))
    (g-io-add-watch channel 'in bindings-callback)))

(define (main args)
  (let* ((menu (make <gtk-menu>))
	 (keywise-app (make <keywise-app> #:menu menu)))
    (set-title menu PROGRAM-NAME)
    (show-all menu)

    ;; ugh
    (set! cycle-class (lambda (number) (-cycle-class keywise-app number)))
    (set! popup-window-list (lambda () (popup-menu keywise-app)))
    (set! wnck-screen (lambda () (get-screen keywise-app)))

    (while (gtk-events-pending) (gtk-main-iteration))

    (options keywise-app args)
    ;;(add-accel-group menu (get-create-accel-group menu))
    (set-accel-group menu (make <gtk-accel-group>))
    (for-each
     (lambda (x) (metacity-bind-key (car x))) METACITY-KEYBINDING-ALIST)
    (init-ipc keywise-app)
    (gtk-main)))