Common Lisp开发的的窗口管理器stumpwm

用sawfish很久了，有点枯燥，就想试试其它窗口管理器。作为一个lisper自然就选择用Common Lisp开发的stumpwm了。stumpwm是一个minimalist窗口管理器，是由原Ratpoison的作者开发。(原来的stumpwm开发已不活跃，就fork一个：hacking用的stumpwm)

用sbcl编译后个头有点大: (如果你在意磁盘文件大小， 可以不用编译，直接将下面这行加入~/.xinitrc:
exec sbcl --eval '(ql:quickload :stumpwm)' --eval '(stumpwm:stumpwm)' )

$ls -l /usr/local/bin/stumpwm

-rwxr-xr-x 1 root root 40751128  2月 11 11:54 /usr/local/bin/stumpwm*

%file /usr/local/bin/stumpwm

/usr/local/bin/stumpwm: ELF 32-bit LSB executable, Intel 80386, version 1 (SYSV), dynamically linked (uses shared libs), for GNU/Linux 2.6.27, BuildID[sha1]=0xe508500dc44ccb4dc6182f6ae5a884f883c26f09, stripped

推荐用有线程支持的clisp编译，生成的执行文件较小：

$ls -l ~/bin/stumpwm

--rwxr-xr-x 1 sw2wolf wheel 8098140 10 9 17:39 /home/sw2wolf/bin/stumpwm*

$file ~/bin/stumpwm

/home/sw2wolf/bin/stumpwm: ELF 32-bit LSB executable, Intel 80386, version 1 (FreeBSD), dynamically linked (uses shared libs), for FreeBSD 9.0 (900044), stripped

编译方法：

$clisp -ansi -modern -q

>(ql:quickload :clx)

>(ql:quickoad :stumpwm)

>(ext:saveinitmem "stumpwm" :init-function (lambda () (stumpwm:stumpwm) (ext:quit))
    :executable t :keep-global-handlers t :norc nil :documentation "The StumpWM Executable")

简单修改~/.xinitrc如下，就可以启动了：

...

case $1 in
    sawfish)
      exec sawfish
      ;;
    *)
      exec $HOME/bin/stumpwm
      ;;
esac

...

配置文件如下：(updated in github)

%cat ~/.stumpwmrc

;; vim:filetype=lisp
(in-package :stumpwm)

;; turn on debugging 0:disable
(setf stumpwm::*debug-level* 0)
;(redirect-all-output (data-dir-file "debug-output" "txt"))
;(set-contrib-dir "/usr/local/share/stumpwm")

(defun cat (&rest strings)
    (apply 'concatenate 'string strings))

;(defun show-key-seq (key seq val)
;    (message (print-key-seq (reverse seq))))
;(add-hook *key-press-hook* 'show-key-seq)

(defmacro replace-hook (hook fn)
    `(remove-hook ,hook ,fn)
    `(add-hook ,hook ,fn))

; If you like Meta (most probably alt on your keyboard) more than
; Super (which is the Windows key on mine), change 's-' into 'M-'.
(defmacro defkey-top (key cmd)
    `(define-key *top-map* (kbd ,key) ,cmd))

(defmacro defkeys-top (&rest keys)
    (let ((ks (mapcar #'(lambda (k) (cons 'defkey-top k)) keys)))
        `(progn ,@ks)))

(defmacro defkey-root (key cmd)
    `(define-key *root-map* (kbd ,key) ,cmd))

(defmacro defkeys-root (&rest keys)
    (let ((ks (mapcar #'(lambda (k) (cons 'defkey-root k)) keys)))
        `(progn ,@ks)))

(defcommand display-current-window-info () ()
  "Shows the properties of the current window. These properties can be
used for matching windows with run-or-raise or window placement
-merules."
  (let ((w (current-window))
        (*suppress-echo-timeout* t)
        (nl (string #\NewLine)))

    ;; (message-no-timeout "class: ~a~%instance~a~%..." (window-class w) (window-res w) ...)
    (echo-string (current-screen)
                 (concat "class:    " (window-class w) nl
                         "instance: " (window-res w) nl
                         "type:     :" (string (window-type w)) nl
                         "role:     " (window-role w) nl
                         "title:    " (window-title w) nl
                         "width:    " (format nil "~a" (window-width w)) nl
                         "height    " (format nil "~a" (window-height w))))))
;
;You need to download stardict-langdao-ec-gb-2.4.2.tar.bz2 and extract it into ~/.stardict
;$ls ~/.stardict/dic/stardict-langdao-ec-gb-2.4.2
; langdao-ec-gb.dict
; langdao-ec-gb.idx
; langdao-ec-gb.idx.oft
; langdao-ec-gb.ifo

; 任何时候按下就可以查单词， 非常方便！
; 除了英汉字典sdcv， 你还可以用英英字典WordNet: wn  -over (需先安装wordnet)
(defcommand sdcv (word) ((:rest "Word> "))
  (let ((cmd (format nil "sdcv -n ~a" word)))
    (with-output-to-string (*standard-output*)
	 #+clisp(let ((str (ext:run-shell-command cmd :output :stream :wait nil)))
	   (loop for line = (read-line str nil)
          until (null line)
          do (print line)))
	 #+sbcl (sb-ext:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*)
	 #+ccl(ccl:run-program "/bin/sh" (list "-c" cmd) :input nil :output *standard-output*))))

(defcommand eval-me (cmd) ((:rest "Eval> "))
    (with-output-to-string (*standard-output*)
        (handler-case
            (format t "~{~a~^~%~}"
                (mapcar 'prin1-to-string
                    (multiple-value-list (eval (read-from-string cmd)))))
            (error (c)
                (format t "~A" c)))))

(set-fg-color "green")
(set-bg-color "black")

(set-float-focus-color "black")
(set-float-unfocus-color "black")

(set-font "-*-simsun-medium-r-normal-*-16-*-*-*-*-*-iso10646-1")
(set-prefix-key (kbd "s-z"))

;; suppress the message StumpWM displays when it starts. Set it to NIL
(setf *startup-message* nil
      *suppress-frame-indicator* t
      *suppress-abort-messages* t
      *timeout-wait* 3
      *mouse-focus-policy* :click ;; :click, :ignore, :sloppy
      *message-window-gravity* :bottom-left
      *input-window-gravity* :bottom-left)

;;; Window Appearance
(setf *normal-border-width* 1
      *maxsize-border-width* 1
      *transient-border-width* 1
      +default-frame-outline-width+ 1
      *float-window-title-height* 0
      *window-border-style* :thin) ; :thick :thin :tight :none

(setf *time-modeline-string* "%Y-%m-%d %a ^B%l:%M^b" 
      *window-name-source* :title
      *window-format* "^B^8*%n%s%m%15t | ^7*"
      *group-format* "%t")

 ;;;; The Mode Line
(setf *mode-line-background-color* "black"
      *mode-line-foreground-color* "lightgreen"
      *mode-line-border-color* "black"
      *mode-line-border-width* 0
      *mode-line-pad-x* 0
      *mode-line-pad-y* 0
      *mode-line-timeout* 60
      *mode-line-screen-position* :top
      *screen-mode-line-format* (list "[^B%n^b]%W" "^>%m | " "^>%d"))

;; turn on/off the mode line for the current screen only.
(if (not (head-mode-line (current-head)))
     (toggle-mode-line (current-screen) (current-head)))
; A head is a physical monitor. A screen is a section of video memory
; that heads are mapped on to. When using xinerama you generally have
; 1 screen and many heads. When not using xinerama each screen is a
; physical monitor so you have many screens with only one head on them.

;;add hook so I get notified when people say my name on IRC or IM me
(defun echo-urgent-window (target)
    (message-no-timeout "~a has an message for you." (window-title target)))
(add-hook *urgent-window-hook* 'echo-urgent-window)

;; shell program used by `run-shell-command' (`sh' by default, which is *not* 'bash' nor 'zsh')
(setf *shell-program* (stumpwm::getenv "SHELL"))

(defparameter +browser-name+ "opera")
(defparameter +browser-class+ "Opera")
;(defparameter +stumpish+ (cat "xterm" " -e ~/bin/stumpish"))

;(defcommand stumpish () ()
;  (run-shell-command +stumpish+))

;(defcommand snapshot () ()
;    (echo-string (current-screen) "Taking Snapshot")
;    (run-shell-command "exec scrot '%m.%d.%Y_%I:%M:%S_%P.png' -e 'mv $f ~/download'"))

(defcommand browse () ()
    (run-or-raise +browser-name+ `(:class ,+browser-class+)))

(defcommand eweiqi () ()
    (run-commands "gselect 2")
    (run-shell-command "wine \"c:/Program Files/eweiqi/LiveBaduk.exe\" &"))

;(defcommand winxp () ()
;    (run-shell-command "VBoxManage startvm winxp &"))

(defcommand reboot () ()
    (run-shell-command "sudo /sbin/shutdown -r now"))

(defcommand halt () ()
    (run-shell-command "sudo /sbin/shutdown -p now"))

(defcommand reinit () ()
    (run-commands "reload" "loadrc"))#|
#|
(defparameter *start-menu*
    '( ("Internet"
            ("Web"   "browse")
            ("WinXP" "winxp")
            ("Go"    "eweiqi"))

       ("Graphics"
            ("gqview"   "gqview")
            ("PDF"      "evince"))
       
       ("System Management"
            ("reboot"  "reboot")
            ("halt"    "halt"))))

(defcommand menu () ()
    "docstring"
    (labels ((pick (options)
        (let ((selection (stumpwm::select-from-menu (current-screen) options "")))
            (cond
                ((null selection)
                    (throw 'stumpwm::error "Abort."))
                ((stringp (second selection))
                    (second selection))
            (t
                (pick (cdr selection)))))))
        (let ((choice (pick *start-menu*)))
            (run-commands choice))))
(define-key *root-map* (kbd "p") "menu")
|#

(defkeys-top
    ("s-w" "browse")
    ("s-p" "exec /home/sw2wolf/bin/dmenu.sh")
    ("s-t" "exec xterm")
    ("s-c" "sdcv")
    ("s-o" "only")
    ("s-s" "vsplit")
    ("s-S" "hsplit")
    ("s-b" "mode-line")
    ("s-Tab" "pull-hidden-next")
    ("Print" "exec scrot -q 10")
    ("M-Print" "exec scrot -q 10 -s")

    ("s-R" "reinit")
    ("s-Q" "quit")
    ("s-F2" "exec")
    ("s-F4" "kill")
    ("s-F11" "reboot")
    ("s-F12" "halt")
   
    ("s-Right" "move-focus right")
    ("s-Left" "move-focus left" )
    ("s-Up" "move-focus up" )
    ("s-Down" "move-focus down" )
    ("s-C-Right" "move-window right")
    ("s-C-Left" "move-window left" )
    ("s-C-Up" "move-window up" )
    ("s-C-Down" "move-window down" )
    ("s-S-Right" "gnext")
    ("s-S-Left" "gprev")
    ("s-S-Up" "prev-in-frame")
    ("s-S-Down" "next-in-frame"))

(defkeys-root
    ("s-e" "eval-me")
    ("s-w" "windowlist")
    ("s-i" "display-current-window-info"))

; groups
(defvar group-names "123")

(dotimes (i 3)
    (define-key *top-map* (kbd (format nil "s-~a" (char group-names i)))
        (format nil "gselect ~a" (1+ i)))
    (define-key *top-map* (kbd (format nil "s-C-~a" (char group-names i)))
        (format nil "gmove ~a" (1+ i))))

(gnewbg-float "2")
(gnewbg "3")

;(replace-hook *mode-line-click-hook*
;    (lambda (mode-line button x y) (grouplist)))

;; display the key sequence in progress
#|
(defun key-press-hook (key key-seq cmd)
    (declare (ignore key))
    (unless (eq *top-map* *resize-map*)
        (let ((*message-window-gravity* :bottom-right))
              (message "Key sequence: ~a" (print-key-seq (reverse key-seq))))
                  (when (stringp cmd)
                        ;; give 'em time to read it
                              (sleep 1.0))))
|#
;(replace-hook *key-press-hook* 'key-press-hook)
;(remove-hook *key-press-hook* 'key-press-hook)

(clear-window-placement-rules)

;(frame-number raise lock &key create restore dump-name class instance type role title)
;(lock AND raise == jumpto)
;(define-frame-preference "Default"
;    (0 t t :class "XTerm")
;    (1 t t :class "Opera"))

;;; mpd
(load-module "mpd")
(setf *mpd-modeline-fmt* "%S [%d|%e] [%s;%r;%v]: %a - %t (%n/%p)")
(setf *mpd-map*
      (let ((m (make-sparse-keymap)))
        (define-key m (kbd "SPC") "mpd-toggle-pause")
        (define-key m (kbd "s") "mpd-toggle-random")
        (define-key m (kbd "r") "mpd-toggle-repeat")
        (define-key m (kbd "S") "mpd-current-song")
        (define-key m (kbd "P") "mpd-play")
        (define-key m (kbd "L") "mpd-browse-playlist")
        (define-key m (kbd "o") "mpd-stop")
        (define-key m (kbd "n") "mpd-next")
        (define-key m (kbd "p") "mpd-prev")
        (define-key m (kbd "c") "mpd-clear")
        (define-key m (kbd "x") "mpd-connect")
        (define-key m (kbd "k") "mpd-kill")
        (define-key m (kbd "u") "mpd-update")
        (define-key m (kbd "a") "mpd-search-and-add-artist")
        (define-key m (kbd "z") "mpd-playlist")
        (define-key m (kbd "v") "mpd-set-volume")
        (define-key m (kbd "e") "mpd-volume-up")
        (define-key m (kbd "d") "mpd-volume-down")
        (define-key m (kbd "S") '*mpd-search-map*)
        (define-key m (kbd "b") '*mpd-browse-map*)
        (define-key m (kbd "A") '*mpd-add-map*)
        m))
(define-key *top-map* (kbd "s-m") '*mpd-map*)
;(define-key *root-map* (kbd "C-m") '*mpd-map*)

(defun my-start-hook ()
    ;(run-shell-command "xsetroot -solid black")
    ;(run-shell-command "fcitx")
    ;(run-shell-command "xterm")
    (vsplit "2/5") (move-focus :down))
(replace-hook *start-hook* 'my-start-hook)

(defvar *swank-p* nil)
(defcommand swank () ()
    (setf stumpwm:*top-level-error-action* :break)
    (if *swank-p*
        (message "Swank server already running")
        (progn
            (setf *swank-p* t)
            (message "Starting swank on port 4005")
            (ql:quickload :swank)
			(funcall (intern (string '#:create-server) :swank) :port 4005 :style :spawn :dont-close t) ; :coding-system "utf-8-unix"
            ;(load "~/.vim/slime/start-swank.lisp")
            (echo-string (current-screen) "Starting Swank...Done")
        )))
(defkey-root "s-l" "swank")