;;; robbe's scwmrc						-*- scwm -*-
;;; Written by Robert Bihlmeyer <robbe@orcus.priv.at>
;;; Snippets were copied from other scwmrcs.
;;; Comments are appreciated.

;;; Rationale:

;; As you can see, this scwmrc was not built to show-off. Contrariwise, one
;; goal is to conserve as much screen real-estate as possible. At the
;; moment, the default is squashed title-bars. No decorations are also an
;; option.

;; An even more important point is full functionality. All things possible
;; with scwm should be available (unless another feature was smuggled in
;; when I was not looking). Since I am reluctant to move my hands from the
;; keyboard, anything has a keyboard shortcut. I require sole control of one 
;; modifier(-combination) for this. (This shouldn't be much of a problem, as 
;; we now see the return of the space-cadet keyboard - in ugly guise.)

;; At last, this file wants to demonstrate some things that are only
;; possible with scwm (so I lied about show-off). But my focus is on more on 
;; inner values than on looks. The main features here are the xlock-menu
;; that automatically adapts to the available modes, and the softs-menu that 
;; excludes applications that were not found in your path.

;;; Roadmap:

;; Please look under "Expected Variables" for things you can override.

;; Key bindings can be found under the heading "Key Bindings". All must be
;; prefixed by the super modifier. This can be changed by overriding `super'.

;; Last exit for the lost: super-d brings back our beloved standard
;; decorations.

;;; Code:

(display "[robbe.scwmrc] Loading modules ...\n")

;;(use-scwm-modules base winops winlist wininfo style face flux optargs
;;		  std-menus animation message-window pie-menus gnome-hints
;;		  xlock-menus placement winlist-menu
;;		  group (ice-9 format) (ice-9 string-fun) (ice-9 regex))

(use-modules (app scwm base)
             (app scwm winops)
             (app scwm winlist)
             (app scwm wininfo)
             (app scwm style)
             (app scwm face)
             (app scwm flux)
             (app scwm optargs)
             (app scwm std-menus)
             (app scwm animation)
             (app scwm message-window)
             (app scwmpie-menus)
             (app scwm gnome-hints)
             (app scwm xlock-menus)
             (app scwm placement)
             (app scwm winlist-menu)
             (app scwm group)
             (ice-9 format)
             (ice-9 string-fun)
             (ice-9 regex))

(display "[robbe.scwmrc] Loading modules ... done.\n")

;; Gnome & SM
(enable-gnome-hints)
(if (not (SM-register))
    (message (SM-error-message)))

;; random niceties
; defines SYM to DEFAULT, unless it is already bound.
(defmacro defvar (sym default)
  `(if (not (symbol-bound? #f (quote ,sym)))
	(define ,sym ,default)))

; Returns whether FILE is an executable and may be executed.
(define (executable? file)
  (and (access? file X_OK)
       (eq? (stat:type (stat file)) 'regular)))

; searches PROGRAMS in the PATH, and returns the full location of the first
; found, or #f if none was found.
(define (which . programs)
  (call-with-current-continuation
   (lambda (return)
     (separate-fields-discarding-char
      #\: (getenv "PATH")
      (lambda path
	(do ((progs programs (cdr progs)))
	    ((null? progs) #f)
	  (if (equal? (string-ref (car progs) 0) #\/)
	      (if (executable? (car progs))
		  (return (car progs)))
	      (do ((dirs path (cdr dirs)))
		  ((null? dirs))
		(let ((loc (string-append (car dirs) "/" (car progs))))
		  (if (executable? loc)
		      (return loc)))))))))))

;; Expected Variables & their defaults
;; Can be overridden by defining them before this point.

;; Uncomment the below to send a single UDP packet to
;; the scwm usage counter machine at startup
;; The single packet just contains the hostname and version number
;; To disable, set environment variable SCWM_DO_NOT_LOG_USAGE
; (define thank-scwm-authors-with-usage-note #t

; default to off
(defvar thank-scwm-authors-with-usage-note #f)

; prepend the proper super modifier (or whatever modifier(s) you want to use)
(defvar super
  (lambda (key) (string-append "s-" key))) ; default is super ("s-")

; prepend super and probably "KP_" - necessary for some keys on sun boxen
(defvar super-kp super)			; default just prepends super

; called upon first entry
(defvar initialize (lambda () #f))	; default does nothing

; a list of desktop names
; these will show up on desk-switches
(defvar Desks '("Main" "Root" "Gimp" "Games"))

;; init functions
(if (not (restarted?))
    (initialize))

;; general settings

; this is done early so I could restart with ease even if there is an error in
; the middle of this file (which of course never happens)
; more less important key bindings are way below
(bind-key 'all (super "r") (lambda () (restart "scwm")))

; paths
(define user-image-load-path 
  (list (string-append (user-home) "/pixmaps")
	(string-append (user-home) "/bitmaps")))
(set! image-load-path 
      (append 
       user-image-load-path 
       '("/usr/X11R6/lib/X11/mini-icons"
	 "/usr/share/pixmaps")
       image-load-path))

; misc
(set-desk-size! 1 1)			; desktops are good, paging is evil
(set-colormap-focus! 'focus)
(set-edge-scroll-delay! #f)
(set-edge-move-threshold! 10)
(set-rubber-band-mask! 255)
(set-animation!
 '#(0 .01 .03 .08 .18 .3 .45 .60 .75 .85 .90 .94 .97 .99 1))

;; style
(define font12
  (make-font "-adobe-times-medium-r-*-*-12-*-*-*-*-*-*-*"))
(define font14 
  (make-font "-adobe-times-medium-r-*-*-14-*-*-*-*-*-*-*"))

(set-icon-font! font12)
(set-highlight-foreground! "black")
(set-highlight-background! "light slate blue")
(set-shadow-factor! 0.4)

(message-window-style default-message-window
		      #:font font12 #:fg "black" #:bg "royal blue")
(menu-style #:fg "black" #:bg "royal blue" #:stipple "maroon"
	    #:font font14)
(title-style #:font font12 #:justify 'left)

(button-style 3 #:relief-pattern	; an X
	      '((26 29 #t) (34 21 #t) (50 35 #t) (68 21 #t) (78 29 #t)
			   (64 48 #f) (78 69 #t) (68 79 #f) (50 64 #f)
			   (34 79 #f) (26 69 #f) (44 48 #t) (26 29 #f)))

					; dot
(button-style 6 #:relief-pattern '((45 45 #t) (55 45 #t) (55 55 #f)
					      (45 55 #f) (45 45 #t)))
					; small down triangle
(button-style 4 #:relief-pattern '((50 65 #t) (35 35 #t) (65 35 #t)
					      (50 65 #f)))
					; small up triangle
(button-style 2 #:relief-pattern '((50 35 #t) (65 65 #f) (35 65 #f)
					      (50 35 #t)))

(window-style "*" 
; highlight   #:fg "white" #:bg "navy"
	      #:fg "black" #:bg "#a3a3c4"
	      #:icon-box (list (x- 70) 1 69 (y- 141))
	      #:focus 'sloppy
	      #:mwm-func-hint #t #:mwm-decor-hint #t
	      #:hint-override #f #:decorate-transient #f
	      #:PPosition-hint #t
	      #:lenience #t
	      #:transient-placement-proc place-at-point)

(define wm-style 'squashed)

(define (set-wm-style! style)
  (let ((styles '((barebones #:border-width 1 #:no-titlebar #t
			     #:squashed-titlebar #f)
		  (squashed #:border-width 1 #:squashed-titlebar #t)
		  (decorated #:border-width 4 #:squashed-titlebar #f))))
    (apply window-unstyle (cons "*" (cdr (assq wm-style styles))))
    (set! wm-style style)
    (apply window-style (cons "*" (cdr (assq wm-style styles))))))

; set to default
(set-wm-style! wm-style)

(define (toggle-wm-style)
  (set-wm-style! (cadr (memq wm-style
			     '(barebones squashed decorated barebones)))))

;; utility functions
(define (toggle-circulate-skip)
  (if (circulate-skip?)
      (circulate-hit)
      (circulate-skip)))

;; menus
; Returns an action that starts X-app NAME by issuing COMMAND.
; If NEEDS-TERM is given, run COMMAND from a terminal.
; If CLASS is given, refrain from starting COMMAND if a window of CLASS exists.
; If RESOURCE is given, don't start COMMAND if a window named RESOURCE exists.
; If CLASS and RESOURCE are both specified, the window must match both.
; If a matching window is found, it is made visible (i.e. desktop is switched,
; window is deiconified, unshaded, and raised).
; unless a window with resourcename RES is already present.
(define* (xcmd-action name command
		      #:key (class #f) (resource #f) (needs-term #f))
  (lambda () 
    (let ((w (if needs-term
		 (find-window-by-name name)
		 (and (or class resource)
		      (find-window-by (win-and?? (class-match?? (or class "*"))
						 (resource-match??
						  (or resource "*"))))))))
      (cond (w (raise-window w)
	       (deiconify-window w)
	       (unshade-window w)
	       (set-current-desk! (window-desk w)))
	    (else (if needs-term
		      (execute (string-append "xterm -title '" name "' -e "
					      command))
		      (execute command)))))))


; Returns a menuitem, titled NAME, that starts X-app COMMAND.
;(define (xcmd-menuitem name command res)
;  (menuitem name #:action (xcmd-action name command #:resource res)))

; Returns a menuitem, titled NAME, that starts a terminal app COMMAND.
;(define (xtcmd-menuitem name command)
;  (menuitem name #:action (xcmd-action name command #:needs-term #t)))

; Returns a menuitem titled "Start WM", that starts that WM instead of scwm.
(define (wm-menuitem wm)
  (menuitem (string-append "Start " wm) #:action (lambda () (restart wm))))


(define xlock-modelist (xlock-query-modes))

(define screen-rows 35)			; this many menuitems fit on the screen

; Returns a menuitem titled MODE that starts xlock in that MODE, adding
; "-nolock" if LOCK is #f.
(define (make-xlock-item lock mode)
  (menuitem mode #:action (lambda () (execute (string-append
						"xlock "
						(if (not lock) "-nolock " "")
						"-nice 5 -mode "
						mode)))))

; Returns a submenu containing xlock calls for MODES. LOCK tells whether the
; screen is really locked. TAG is appended to the menu title.
(define (make-xlock-submenu tag lock modes)
  (menu
   (append
    (list
     (menu-title (string-append (if lock "Lock" "Save") " Screen" tag))
     menu-separator)
    (map (lambda (mode) (make-xlock-item lock mode)) modes))))

; Returns MENULIST augmented with a menuitem, that calls a submenu containing
; MODES (where the last mode beginns with character LAST). LOCK controls,
; whether the screen is really locked.
(define (append-xlock-submenu menulist lock last modes)
  (let ((tag (string #\space (string-ref (car modes) 0) #\- last)))
    (append menulist
	    (list (menuitem (substring tag 1 4) #:action
			    (make-xlock-submenu tag lock modes))))))

; Returns a menu providing access to xlock MODES. If this menu would be longer
; than the screen height, the MODES are split among several submenus instead.
; LOCK chooses between screen-locking and -saving.
(define (make-xlock-menu lock modes)
  (if (> (length modes) screen-rows)
      (do ((current '())
	   (potential '() (cons (car rest) potential))
	   (omega #\z)
	   (rest modes (cdr rest))
	   (template (list (menu-title (if lock "Lock Screen" "Save Screen"))
			   menu-separator)))
	  ((null? rest) (menu (append-xlock-submenu
			       template lock
			       (string-ref (car potential) 0)
			       (append current (reverse potential)))))
	(if (> (+ (length current) (length potential)) screen-rows)
	    (begin
	      (set! template (append-xlock-submenu template lock
						   omega current))
	      (set! current '())))
	(if (and (pair? potential)
		 (not (char-ci=? (string-ref (car potential) 0)
				 (string-ref (car rest) 0))))
	    (begin
	      (set! omega (string-ref (car potential)))
	      (set! current (append current (reverse potential)))
	      (set! potential '()))))
      (make-xlock-submenu "" lock modes)))


; Returns the full path of (car ARGS), concatenated with (cdr ARGS).
(define (which-1 args)
  (let ((prog (which (car args))))
    (and prog
	 (apply string-append prog (cdr args)))))

(define (build-menu title template)
  "Returns a menu named TITLE, built according to TEMPLATE.
TEMPLATE is a list of item definitions. An item definition may be a list,
a menuitem, or a menu.

If a list, it is interpreted as follows:
	(NAME COMMAND [CLASS])
This results in a menuitem named NAME, executing COMMAND.
If CLASS is not given, COMMAND is always executed.
If CLASS is a string, COMMAND is executed, unless a window of
class CLASS is already present.
If CLASS is the symbol `term', COMMAND is executed inside a xterm titled NAME,
unless a window titled NAME is already present.
COMMAND may also be a list of strings, in which case the first found
in the PATH is used. If COMMAND (or neither member therof) is not found,
no menuitem is emitted.

If a menuitem or menu, it is used verbatim. This includes, for example, the
special menuitem `menu-separator', or submenus built with `build-menu'."
  (menu
   (append
    (list
     (menu-title title) menu-separator)
    (delete #f (map
		(lambda (item)
		  (if (list? item)
		      (let* ((action (cadr item))
			     (cmd (cond ((list? action) (apply which action))
					((string? action)
					 (which-1 (split-before-char
						   #\  action list)))
					(else #t))))
			(if cmd
			    (menuitem
			     (car item) #:action
			     (cond ((menu? action) action)
				   ((not (null? (cddr item)))
				    (let ((name (regexp-substitute/global
						 #f "&" (car item)
						 'pre 'post)))
				      (if (eq? (caddr item) 'term)
					  (xcmd-action name cmd
						       #:needs-term #t)
					  (xcmd-action name cmd
						       #:resource
						       (caddr item)))))
				   (else (lambda () (execute cmd)))))
			    #f))
		      item))
		template)))))

(define softs-menu
  (build-menu "Softs" `(("X&Term" "xterm")
		       ("&Rxvt" "rxvt")
		       ,(if (which "xemacs")
			    '("X&Emacs" "xem" "emacs")
			    '("&Emacs" "emacs" "emacs"))
		       ("&Netscape" ("netscape4.08s" "netscape4s"
						     "netscpape4" "netscape")
				    "Netscape")
		       ("Gnome &Panel" ("gnome panel" "panel"))
		       ,menu-separator
		       ("&Aural Stims"
			,(build-menu "Aural Stims"
				     '(("&Mixer" ("mix2000" "gmix"))
				       ("X&Cd" "xcd")
				       ("X&Synaesthesia" "xsynaesthesia cd"
							 "xsynaesthesia")
				       ("G&mp3" "gmp3" "gmp3")
				       ("&Gqmpeg" "gqpmpeg"))))
		       ("&Visual Stims"
			,(build-menu "Visual Stims"
				     '(("X&colmix" "xcolmix" "colorMixer")
				       ("X&Mag" "xmag" "xmag")
				       ("&Gimp"
			"xterm -g 80x5+0-0 -T GimpConsole -e gimp" "gimp")
				       ("X&Paint" "xpaint" "xpaint")
				       ("X&Fig" "xfig" "xfig"))))
		       ("&State Info"
			,(build-menu "State Info"
				     '(("&Top" "top" term)
				       ("&Procinfo" "procinfo -f" term)
				       ("X&Load" "xload" "xload")
				       ("X&Idle" "xidle" "xidle")
				       ("X&Mem" "xmem" "xmem"))))
		       ,menu-separator
		       ("Save S&creen" ,(make-xlock-menu #f xlock-modelist))
		       ("&Lock Screen" ,(make-xlock-menu #t xlock-modelist))
		       ,menu-separator
		       ("E&xit scwm"
			,(build-menu "Really quit scwm?"
				     (list
				      (menuitem "&Restart scwm"
						#:extra-label "r"
						#:action (lambda ()
							   (restart "scwm")))
				      (wm-menuitem "fvwm")
				      (wm-menuitem "enlightenment")
				      (wm-menuitem "twm")
				      (menuitem "Start &no wm"
						#:action (lambda ()
							   (restart "xterm")))
				      (menuitem "&Quit" #:extra-label "S-q"
						#:action quit)
				      menu-separator
				      (menuitem "Logout" #:action
						(lambda () (system "save-session --kill &")))))))))

(define (popup-softs)
  (popup-menu softs-menu))

(define (xwininfo-window)
  (execute (string-append "xwininfo -id " (number->string (window-id))
			  " | xmessage -nearmouse -file -")))
(define window-ops-menu
  (menu
   (list
    (menu-title "Window Ops" #f) menu-separator
    (menuitem "&Move" #:extra-label "F5" #:action interactive-move)
    (menuitem "Re&size" #:extra-label "F6" #:action interactive-resize)
    (menuitem "&Raise" #:action raise-window)
    (menuitem "&Lower" #:action lower-window)
    (menuitem "(Un)&Window-Shade" #:action toggle-window-shade)
    (menuitem "(De)&Iconify" #:extra-label "F4" #:action toggle-iconify)
    (menuitem "(Un)&Maximize" #:extra-label "F8"
	      #:action toggle-maximize-vertical)
    (menuitem "(Un)&Stick" #:extra-label "Return" #:action toggle-stick)
    (menuitem "(Un)Keep On &Top" #:extra-label "Home" #:action toggle-on-top)
    (menuitem "(Un)S&kip" #:extra-label "Ins" #:action toggle-circulate-skip)
    menu-separator
    (menuitem "Properties" #:action show-X-properties)
    (menuitem "Info" #:action xwininfo-window)
    menu-separator
    (menuitem "&Close" #:extra-label "Del" #:action close-window)
    (menuitem "&Delete" #:action delete-window)
    (menuitem "Destroy" #:action destroy-window)
    menu-separator
    (menuitem "Refresh Screen" #:action refresh))))

(define (popup-window-ops)
  (popup-menu window-ops-menu))

(define tooltip-window (make-message-window ""))

(define (tooltip-show tip)
  (message-window-set-message! tooltip-window tip)
  (apply message-window-set-position! `(,tooltip-window ,@(pointer-position) -1 -1))
  (message-window-show! tooltip-window))

(define (tooltip-hide)
  (message-window-hide! tooltip-window))

(define (popup-small-ops)
  (let ((w (get-window)))
    (popup-menu
     (menu 
      (list
       (menuitem "M" #:image-above "/usr/share/pixmaps/move.xpm"
		 #:action interactive-move
		 #:hover-action (lambda ()
				  (tooltip-show "move"))
		 #:unhover-action tooltip-hide)
       (menuitem "#" #:image-left "/home/robbe/pixmaps/resize.xpm"
		 #:action interactive-resize
		 #:hover-action (lambda ()
				  (tooltip-show "resize"))
		 #:unhover-action tooltip-hide)
       (menuitem "+" #:action raise-window
		 #:hover-action (lambda ()
				  (tooltip-show "raise"))
		 #:unhover-action tooltip-hide)
       (menuitem "-" #:action lower-window
		 #:hover-action (lambda ()
				  (tooltip-show "lower"))
		 #:unhover-action tooltip-hide)
       (menuitem "v" #:image-left "minimize.xpm"
		 #:action toggle-iconify
		 #:hover-action (lambda ()
				  (tooltip-show "iconify"))
		 #:unhover-action tooltip-hide)
       menu-separator
       (menuitem ">" #:action
		 (menu
		  (list
		   (menuitem (if (maximized? w) "~^" "^")
			     #:image-left "maximize.xpm"
			     #:action toggle-maximize-vertical
			     #:hover-action (lambda ()
					      (tooltip-show
					       "vertical maximize"))
			     #:unhover-action tooltip-hide)
		   (menuitem (if (sticky-window? w) "~*" "*")
			     #:action toggle-stick
			     #:hover-action (lambda ()
					      (tooltip-show "stick"))
			     #:unhover-action tooltip-hide)
		   (menuitem (if (shaded-window? w) "~=" "=")
			     #:action toggle-window-shade
			     #:hover-action (lambda ()
					      (tooltip-show "shade"))
			     #:unhover-action tooltip-hide)
		   (menuitem (if (kept-on-top? w) "~T" "T")
			     #:action toggle-on-top
			     #:hover-action (lambda ()
					      (tooltip-show "keep on top"))
			     #:unhover-action tooltip-hide)
		   (menuitem (if (circulate-skip? w) "~S" "S")
			     #:action toggle-circulate-skip
			     #:hover-action (lambda ()
					      (tooltip-show "circulate skip"))
			     #:unhover-action tooltip-hide)
		   menu-separator
		   (menuitem "P" #:action show-X-properties
			     #:hover-action (lambda ()
					      (tooltip-show "properties"))
			     #:unhover-action tooltip-hide)
		   (menuitem "?" #:action xwininfo-window
			     #:hover-action (lambda ()
					      (tooltip-show "win info"))
			     #:unhover-action tooltip-hide))
		  #:look circle-pie-menu-look))
       menu-separator
       (menuitem "X" #:action close-window
		 #:hover-action (lambda ()
				  (tooltip-show "close"))
		 #:unhover-action tooltip-hide)
       (menuitem "D" #:action destroy-window
		 #:hover-action (lambda ()
				  (tooltip-show "destroy"))
		 #:unhover-action tooltip-hide))
      #:look circle-pie-menu-look))))

(define (popup-winlist)
  (show-window-list-menu #f #f #:show-geometry #t))

(define (last-focussed win)
  (if (equal? win (window-with-focus))
      0
      (window-last-focus-time win)))

(define focus-locked #f)

(define (rb:focus win)
  (cond ((and win (not focus-locked)) (deiconify-window win)
				      (raise-window win)
				      (focus-window win))))

(define (rb:warp win)
  (cond ((and win (not focus-locked)) (deiconify-window win)
				      (raise-window win)
				      (warp-to-window win)
				      (focus-window win))))

(define (toggle-focus)
  "Focus window that had the focus before the current one."
  (rb:warp (extreme (lambda (win1 win2) (> (last-focussed win1)
						  (last-focussed win2)))
			   (list-all-windows))))


;; Key Bindings
; mouse emulation
(define (mouse-movers mods pixels left down up right)
  (bind-key 'all (apply mods (list left))
	    (lambda () (move-pointer (- pixels) 0)))
  (bind-key 'all (apply mods (list right))
	    (lambda () (move-pointer pixels 0)))
  (bind-key 'all (apply mods (list up))
	    (lambda () (move-pointer 0 (- pixels))))
  (bind-key 'all (apply mods (list down))
	    (lambda () (move-pointer 0 pixels))))
(mouse-movers super 1 "KP_Left" "KP_Down" "KP_Up" "KP_Right")
(mouse-movers (lambda (key) (super (string-append "S-" key))) 10
	      "KP_Left" "KP_Down" "KP_Up" "KP_Right")
(bind-key 'all (super "KP_Divide") (lambda () (send-button 1)))
(bind-key 'all (super "KP_Multiply") (lambda () (send-button 2)))
(bind-key 'all (super "KP_Subtract") (lambda () (send-button 3)))

; backdrop action
(bind-key 'all (super "F1") popup-softs)
(bind-key 'all (super "F2") popup-window-ops)
(bind-key 'all (super "F3") popup-winlist)
; window manipulation
(bind-key 'all (super "S-F4") iconify-group)
(bind-key 'all (super "F4") toggle-iconify)
(bind-key 'all (super "F5") interactive-move)
(bind-key 'all (super "F6") interactive-resize)
(bind-key 'all (super "F7") toggle-maximize-horizontal)
(bind-key 'all (super "F8") toggle-maximize-vertical)
(bind-key 'all (super "Return") toggle-stick)
(bind-key 'all (super-kp "Home") toggle-on-top)
(bind-key 'all (super-kp "Insert") toggle-circulate-skip)
(bind-key 'all (super "Delete") close-window)
; window selection
(define (xterm? w)
  (wildcard-match? "xterm" w))
(define (visible-xterm? w)
  (and (visible? w)
       (wildcard-match? "xterm" w)))
(define (unfocusable? w)
  (or (equal? (window-focus-style w) 'none)
      (equal? (window-focus-style w) 'click)))
(define (iconified-or-unfocusable? w)
  (or (iconified-window? w)
      (shaded-window? w)
      (unfocusable? w)))

(define (bind-circulate fwd bwd . args)
  (bind-key 'all fwd (lambda () (apply next-window args)))
  (bind-key 'all bwd (lambda () (apply prev-window args))))

(bind-circulate (super "F9") (super "F10") 
		#:only visible-xterm? #:except iconified-or-unfocusable?)
(bind-circulate (super "S-F9") (super "S-F10") 
		#:only xterm? #:except iconified-or-unfocusable?)
(bind-circulate (super-kp "Left") (super-kp "Right") 
		#:only visible? #:except iconified-or-unfocusable?
		#:proc rb:warp)
(bind-circulate (super-kp "Up") (super-kp "Down")
		#:only visible? #:except unfocusable? #:proc rb:focus)

(bind-key 'all (super "space") toggle-focus)

; desk switching
(define focused-windows '())

(define (change-desk inc)
  (set-current-desk! (+ (current-desk) inc)))

(define (remember-focus new-desk desk)
  (let ((win (window-with-focus)))
    (if win
	(let ((ref (assoc desk focused-windows)))
	  (if ref
	      (set-cdr! ref win)
	      (set! focused-windows (cons (cons desk win) focused-windows)))))
    (let ((ref (assoc new-desk focused-windows)))
;      (write `(leaving desk ,desk and focus ,win new desk ,ref)) 
      (cond
       ((and win (on-current-desk? win)) (focus-window win))
       ((and ref (on-current-desk? (cdr ref))) (focus-window (cdr ref)))
       (else (next-window #:proc focus))))))

(add-hook! change-desk-hook remember-focus)

(define (show-message-briefly msg msec)
  (let ((mw (make-message-window-clone-default msg)))
    (message-window-show! mw)
    (add-timer-hook! msec (lambda () (message-window-hide! mw)))))

(add-hook! change-desk-hook (lambda (new-desk old-desk)
			      (show-message-briefly (list-ref Desks new-desk)
						    1000)))

(define (index el list)
  (let ((tail (member el list)))
    (if tail
	(- (length list)
	   (length tail))
	#f)))

(define (desk-number name)
  (index name Desks))

(bind-key 'all (super-kp "Page_Up")
	  (lambda () (change-desk -1)))
(bind-key 'all (super-kp "Page_Down")
	  (lambda () (change-desk +1)))

(do ((i 0 (1+ i)))
    ((>= i 9))
  (bind-key 'all (super (format "~d" (1+ i)))
	    (lambda () (set-current-desk! i))))

; misc
(bind-key 'all (super "d") toggle-wm-style)
(bind-key 'all (super "S-q") quit)


;; Mouse Bindings
(bind-mouse 'root 1 popup-softs)
(bind-mouse 'root 2 popup-window-ops)
(bind-mouse 'root 3 popup-winlist)
#! -- "no buttons!" is my newest fad
(bind-mouse 'left-button-1 1 popup-small-ops)
(bind-mouse 'left-button-2 1 (lambda () (case (mouse-event-type)
				     ('click (close-window))
				     ('double-click (destroy-window)))))
(bind-mouse 'right-button-3 1 toggle-stick)
(bind-mouse 'right-button-2 1 iconify-window)
(bind-mouse 'right-button-1 1
	    (lambda () (case (mouse-event-type)
			 ('click (toggle-maximize-vertical))
			 ('double-click (toggle-maximize (%x 100) (%y 100))))))
!#
(bind-mouse 'frame-corners 1 resize-or-raise)
(bind-mouse 'frame-sides 1 move-or-raise)
(define (move-or-shade)
  (case (mouse-event-type)
    ((double-click) (animated-toggle-window-shade))
    (else (move-or-raise))))
(bind-mouse 'title 1 move-or-shade)
(define (move-or-deiconify)
  (case (mouse-event-type)
    ((motion) (interactive-move))
    ((double-click) (deiconify-group-or-window))))
(bind-mouse 'icon 1 move-or-deiconify)
(bind-mouse 'icon 2 deiconify-group-or-window)
(bind-mouse '(title frame-sides frame-corners) 2 (lambda () (popup-small-ops)))
(bind-mouse '(title frame-sides frame-corners) 3 toggle-raise)
(bind-mouse 'all (super "1") move-or-raise)
(bind-mouse 'all (super "2") popup-small-ops)
(bind-mouse 'all (super "3") resize-or-raise)

;; Styles for various apps
(define FixedSize
  (make-style #:border-width 0 #:no-button 2))
(define NoFocus
  (make-style #:focus 'click #:circulate-skip #t))
(define Widget
  (make-style #:no-titlebar #t #:plain-border #t #:sticky #t
	      #:winlist-skip #t #:border-width 3 #:use-style NoFocus))

(window-style (title-match?? "Color Mixer")
	      #:icon "colormap_3d.xpm.gz"
	      #:use-style FixedSize #:use-style NoFocus)
(window-style (class-match?? "Gimp")
	      #:start-on-desk (desk-number "Gimp"))
(window-style (resource-match?? "gimp_startup")
	      #:start-on-desk #f)
(window-style (title-match?? "GimpConsole")
	      #:start-on-desk (desk-number "Gimp") #:skip-mapping #t)
(window-style (title-match?? "GTimer")
	      #:start-lowered #t #:use-style NoFocus)
(window-style (class-match?? "GTimeTracker")
	      #:start-lowered #t)
(window-style (class-match?? "Nethack")
	      #:start-on-desk (desk-number "Games"))

(define (place-ns-find w)
  (let* ((ns-pos (window-viewport-position (window-transient-for w)))
	 (x (min (+ (car ns-pos) 300) (- display-width 378)))
	 (y (max (- (cadr ns-pos) 30) 0)))
    (move-to x y w)
    (move-pointer-to (+ x 30) (+ y 55))))

(window-style (title-match?? "Netscape: Find")
	      #:transient-placement-proc place-ns-find)

(window-style (title-match?? "UAE")
	      #:icon "amiga.xpm.gz"
	      #:placement-proc (lambda (win)
				 (move-to 0 0 win)))
(window-style (title-match?? "Control")
	      #:icon "amiga.xpm.gz" #:use-style FixedSize
	      #:placement-proc (lambda (win)
				 (move-to 600 0 win)))
(window-style (title-match?? "UAE - Debuger")
	      #:icon "amiga.xpm.gz" #:use-style FixedSize)
(window-style (title-match?? "XCd")
	      #:icon "CompactDisc.xpm.gz"
	      #:random-placement #t #:use-style FixedSize)
(window-style (title-match?? "XZip Status")
	      #:placement-proc (lambda (win) (move-window-to-desk 1 win)
				       (move-to 0 0 win))
	      #:kept-on-top #t
	      #:use-style FixedSize)
(window-style (title-match?? "XZip")
	      #:start-on-desk (desk-number "Games")
	      #:use-style FixedSize)
(window-style (title-match?? "povray")
	      #:icon "xpovicon.xpm.gz" ;; #:placement-proc random-place-window
	      #:use-style FixedSize)
(window-style (title-match?? "rxvt*")
	      #:icon "term.xpm.gz")
(window-style (title-match?? "xcalc")
	      #:icon "Calculator.xpm.gz")
(window-style (title-match?? "xclock")
	      #:use-style Widget)
(window-style (title-match?? "xconsole")
	      #:icon "rterm.xpm.gz" #:use-style NoFocus)
(window-style (title-match?? "xmag")
	      #:icon "view_3d.xpm.gz" ;; #:placement-proc random-place-window
	      #:use-style NoFocus)
(window-style (title-match?? "xman")
	      #:icon "xman.xpm.gz" ;; #:placement-proc random-place-window
	      #:use-style NoFocus)
(window-style (class-match?? "XSm")
	      #:focus 'click)
(window-style (class-match?? "XTerm")
	      #:icon "xterm-linux.xpm.gz")
(window-style (title-match?? "xv controls")
	      #:icon "xv.color.xpm.gz" #:use-style FixedSize
	      #:use-style NoFocus)
(window-style (title-match?? "xv load")
	      #:icon "xv.color.xpm.gz" #:use-style FixedSize
	      #:use-style NoFocus)
(window-style (title-match?? "xterm root*")
	      #:start-on-desk (desk-number "Root"))

(window-style (title-match?? "bitmap")
	      #:icon "draw3_3d.xpm.gz")
(window-style (title-match?? "editres")
	      #:icon "editres_3d.xpm.gz")
(window-style (title-match?? "ghostview")
	      #:icon "ghostbuster.xpm.gz")
(window-style (title-match?? "lyx")
	      #:icon "WordProcessing.xpm.gz")
(window-style (title-match?? "minicom")
	      #:icon "DFUe.xpm.gz")
(window-style (title-match?? "mpeg_*")
	      #:icon "Animator.xpm.gz")
(window-style (title-match?? "oclock")
	      #:icon "clock4_3d.xpm.gz")
(window-style (title-match?? "viewres")
	      #:icon "flowchart_3d.xpm.gz")
(window-style (title-match?? "x*perf*")
	      #:icon "meter_3d.xpm.gz")
(window-style (title-match?? "xbiff")
	      #:icon "Mail.xpm.gz")
(window-style (title-match?? "xclipboard")
	      #:icon "data_3d.xpm.gz")
(window-style (title-match?? "xcmap")
	      #:icon "colormap_3d.xpm.gz")
(window-style (title-match?? "xcutsel")
	      #:icon "data_3d.xpm.gz")
(window-style (title-match?? "xditview")
	      #:icon "cadview.next.xpm.gz")
(window-style (title-match?? "xdos")
	      #:icon "win31_msdos.xpm.gz")
(window-style (title-match?? "xdvi")
	      #:icon "xdvi.next.xpm.gz")
(window-style (title-match?? "xfig")
	      #:icon "Drawing2.xpm.gz")
(window-style (title-match?? "xfontsel")
	      #:icon "fonts_3d.xpm.gz")
(window-style (title-match?? "xfractint")
	      #:icon "Fractal.xpm.gz")
(window-style (title-match?? "xgc")
	      #:icon "xdesigner_3d.xpm.gz")
(window-style (title-match?? "xhextris")
	      #:icon "Tetris.xpm.gz")
(window-style (title-match?? "xpcd")
	      #:icon "gold_cone_3d.xpm.gz")
(window-style (title-match?? "xvidtune")
	      #:icon "window3d.xpm.gz")
(window-style (title-match?? "xwud")
	      #:icon "Viewer.xpm.gz")

; list of windows currently flashing
(define flash-window-list '())

(define* (flash-window-start
	  #:optional (win (select-window-interactively "Flash what?")))
  "Color-cycle WIN's title."
  (if (not (member win flash-window-list))
      (letrec ((n 0)
	       (timestep 100000)
	       (action
		(lambda (col)
		  (set-window-foreground!
		   (string-append "grey" (number->string col)) win)))
	       (schedule
		(lambda (proc)
		  (if (member win flash-window-list)
		      (add-timer-hook! timestep proc)
		      ; FIXME: should restore colors better
		      (for-each
		       (lambda (hook)
			 (hook win))
		       (variable-ref (module-variable
				      (resolve-module '(app scwm style))
				      'window-style-hooks))))))
	       (count-up
		(lambda ()
		  (if (<= n 100)
		      (begin
			(action n)
			(set! n (+ n 10))
			(schedule count-up))
		      (schedule count-down))))
	       (count-down
		(lambda ()
		  (if (> n 0)
		      (begin
			(set! n (- n 10))
			(action n)
			(schedule count-down))
		      (schedule count-up)))))
	(set! flash-window-list (cons win flash-window-list))
	(schedule count-up))))

(define* (flash-window-stop
	  #:optional (win (select-window-interactively "Stop flashing what?")))
  "Stop color-cycling WIN's title."
  (set! flash-window-list (delete win flash-window-list)))