stumpwmrc.lisp

;; -*-lisp-*-
;;
;; Here is a sample .stumpwmrc file

(in-package :stumpwm)

(set-prefix-key (kbd "C-t"))

;;; log to debug output
(redirect-all-output (data-dir-file "debug" "log"))

(defcommand debug-toggle () ()
  "Toggle debug logging."
  (progn
    (if (= stumpwm::*debug-level* 0)
        (setf stumpwm::*debug-level* 10)
        (setf stumpwm::*debug-level* 0))))

;; load Swank so we can connect with SLIME
(load "/usr/share/common-lisp/source/slime/swank-loader.lisp")
(swank-loader:init)
(defvar *swank-p* nil)

;; define swank command to start swank server on port 4005
(defcommand swank () ()
  "Starts a swank server on port 4005 and notifies the user."
  (setf stumpwm:*top-level-error-action* :break)
  (if *swank-p*
      (message "Swank server already running.")
      (progn
        (swank:create-server :port 4005
                             :style swank:*communication-style*
                             :dont-close t)
        (setf *swank-p* t)
        (message "Starting swank on port 4005."))))


;;; variables
(set-module-dir "~/opt/stumpwm-contrib")

(setf *default-groups*
      '("www"                                ;1
        "irc"                                ;2
        "mail"                               ;3
        "emacs"                              ;4
        "enableit"                           ;5
        "projects"                           ;6
        "stuff"                              ;7
        "repl"                               ;8
        "clojure"                            ;9
        "shell1"                             ;10
        "shell2"                             ;11
        "shell3"))

;; (setf *screen-mode-line-format* "[^B%n^b] %W %d %C %l %M | %N")
(setf *screen-mode-line-format* "[^B%n^b] %W %d %C %l %M")


;;; functions
(defun initialize-groups ()
  (let* ((screen (current-screen))
         (group (current-group))
         (groups (or (if (string-equal (group-name group) *default-group-name*)
                         (progn
                           (setf (group-name group) (car *default-groups*))
                           (cdr *default-groups*)))
                     *default-groups*)))
    (map
     nil
     (lambda (name)
       (unless (find-group screen name)
         (add-group screen name)))
     groups)))

(defun message-urgent-window (target)
  (message-no-timeout "~a has an message for you." (window-title target)))
(add-hook *urgent-window-hook* 'message-urgent-window)


;;; commands
(defcommand show-ip-addrs () ()
  "Shows the output of `ip addr`."
  (run-shell-command "ip addr | grep -Eo '^([0-9]| +inet6? ).+'" t))

(defcommand show-battery () ()
  "Shows the output of `ip addr`."
  (run-shell-command "acpitool -b" t))


;;; initialization
(initialize-groups)

(load-module "cpu")
(load-module "mem")
(load-module "net")
;; (load-module "notifications")

(load "~/quicklisp/setup.lisp")

(ql:quickload "xembed")
(ql:quickload "alexandria")
(load-module "stumptray")
(stumptray:add-mode-line-hooks)



;;; key bindings and mouse
;; click to focus windows
(setf *mouse-focus-policy* :click)

;; add shortcuts to groups 1-9
(loop for i from 1 to 9
   do (define-key *top-map*
          (kbd (format nil "s-~D" i))
        (format nil "gselect ~D" i)))

;; (define-key *root-map* (kbd "N") 'notifications:*notifications-map*)

;; other key bindings
(define-key *top-map* (kbd "s-quoteleft") "gother")
(define-key *top-map* (kbd "C-s-Left") "gprev")
(define-key *top-map* (kbd "C-s-Right") "gnext")
(define-key *top-map* (kbd "s-Left") "move-focus left")
(define-key *top-map* (kbd "s-Right") "move-focus right")
(define-key *top-map* (kbd "s-Up") "move-focus up")
(define-key *top-map* (kbd "s-Down") "move-focus down")
(define-key *top-map* (kbd "S-s-Left") "exchange-direction left")
(define-key *top-map* (kbd "S-s-Right") "exchange-direction right")
(define-key *top-map* (kbd "S-s-Up") "exchange-direction up")
(define-key *top-map* (kbd "S-s-Down") "exchange-direction down")
(define-key *top-map* (kbd "s-n") "pull-hidden-next")
(define-key *top-map* (kbd "s-p") "pull-hidden-previous")
(define-key *top-map* (kbd "s-b") "mode-line")

(define-key *root-map* (kbd "I") "show-window-properties")

(define-key *root-map* (kbd "C-l") "exec slock xset dpms force off")
(define-key *root-map* (kbd "C-L") "exec slock systemctl off")
(define-key *root-map* (kbd "C-M-L") "exec slock systemctl hibernate")

(define-key *root-map* (kbd "C-F11") "show-ip-addrs")
(define-key *root-map* (kbd "C-F12") "show-battery")

(define-key *top-map* (kbd "S-s-F7")               "exec mpc prev")
(define-key *top-map* (kbd "S-s-F8")               "exec mpc next")
(define-key *top-map* (kbd "XF86AudioPlay")        "exec mpc toggle")
(define-key *top-map* (kbd "S-s-F9")               "exec mpc toggle")
(define-key *top-map* (kbd "XF86AudioMute")        "exec pavolume mutetoggle")
(define-key *top-map* (kbd "S-s-F10")              "exec pavolume mutetoggle")
(define-key *top-map* (kbd "XF86AudioLowerVolume") "exec pavolume voldown")
(define-key *top-map* (kbd "S-s-F11")              "exec pavolume voldown")
(define-key *top-map* (kbd "XF86AudioRaiseVolume") "exec pavolume volup")
(define-key *top-map* (kbd "S-s-F12")              "exec pavolume volup")

(define-key *top-map* (kbd "XF86MonBrightnessUp")   "exec brightness up")
(define-key *top-map* (kbd "XF86MonBrightnessDown") "exec brightness down")

;;; installing quicklisp
;; $ curl -O https://beta.quicklisp.org/quicklisp.lisp
;; $ curl -O https://beta.quicklisp.org/quicklisp.lisp.asc
;; $ gpg --verify quicklisp.lisp.asc quicklisp.lisp
;; $ sbcl --load quicklisp.lisp
;; (quicklisp-quickstart:install)
;; (ql:quickload system-name)
#+nil
(if nil
    (gnext)
    (progn

      (let* ((ml (head-mode-line (current-head)))
             (mlh (mode-line-head ml))
             (current-head-width (head-width mlh))
             (s (current-screen))
             (f (screen-font s))
             (*current-mode-line-formatters* *screen-mode-line-formatters*)
             (*current-mode-line-formatter-args* (list ml))
             (mode-line-string (mode-line-format-string ml))
             (space-width (xlib:text-width f " ")))

        (mode-line-mode ml)
        (mode-line-window ml)
        current-head-width

        (xlib:text-width f mode-line-string))

      (+ 3840 1920 1920)

      (let* ((ml (head-mode-line (current-head)))
             (*current-mode-line-formatters* *screen-mode-line-formatters*)
             (*current-mode-line-formatter-args* (list ml))
             (string (mode-line-format-string ml)))
        string)

      (defcommand (next-in-group tile-group) () ()
        "Go to the next window in the current group."
        (let* ((group (current-group))
               (windows (group-windows group)))
          windows
          ;; (if (group-current-window group)
          ;;     (focus-forward group (frame-sort-windows group (tile-group-current-frame group)))
          ;;     (other-window-in-frame group))
          ))



      (define-key *top-map* (kbd "s-Page_Down") "mode-line")
      (undefine-key *top-map* (kbd "s-Page_Up"))
      (undefine-key *top-map* (kbd "s-Page_Down"))))

(defun list-groups (&optional
                      (screen (current-screen))
                      (verbose nil)
                      (wfmt *window-format*))
  (let* ((groups (sort-groups (current-screen)))
         (names (mapcan
                 (lambda (g)
                   (list*
                    (format-expand *group-formatters* *group-format* g)
                    (when verbose
                      (mapcar (lambda (w)
                                (format-expand *window-formatters*
                                               (concatenate 'string "  " wfmt)
                                               w))
                              (sort-windows g)))))
                 (if *list-hidden-groups* groups (non-hidden-groups groups)))))
    names))

#+nil
(progn
  (defun move-focus-and-or-window (dir &optional win-p)
    (declare (type (member :up :down :left :right) dir))
    (let* ((group (current-group))
           (new-frame )
           (window (current-window)))
      (when new-frame
        (if (and win-p window)
            (pull-window window new-frame)
            (focus-frame group new-frame)))))

  (defcommand testheads (dir) ((:direction "Direction: "))
    (let* ((group (current-group))
           (other-frame (neighbour dir (tile-group-current-frame group) (group-frames group)))
           (other-head (frame-head group other-frame)))
      (message "other-frame ~S~&other-head ~S" other-frame other-head)))

  (defvar *head-focus-map* nil)

  (defcommand (move-focus-2 tile-group) (dir) ((:direction "Direction: "))
    "Focus the frame adjacent to the current one in the specified
      direction. The following are valid directions:
      @table @asis
      @item up
      @item down
      @item left
      @item right
      @end table"
    (move-focus-and-or-window dir))

  (defun read-key ()
    "Return a dotted pair (code . state) key."
    (loop for ev = (xlib:process-event *display* :handler #'read-key-handle-event :timeout nil) do
         (when (and (consp ev)
                    (eq (first ev) :key-press))
           (return (rest ev)))))

  (defvar *group-cycle-index* NIL)
  (defvar *group-cycle-group-list* NIL)

  (defcommand gcycle () ()
    "Cycle through the group list"
    (progn
      ;; if the previous command was not gcycle we reset the index and copy
      ;; the group list
      (message "doing stuff")
      (if (or
           (string-not-equal *last-command* "gcycle")
           (not *group-cycle-index*)
           (not *group-cycle-group-list*))
          (progn
            (setq *group-cycle-index* 0)
            (setq *group-cycle-group-list* (screen-groups (current-screen)))))
      ;; increment the index into the group list
      (incf *group-cycle-index*)
      (switch-to-group (nth *group-cycle-index* *group-cycle-group-list*))))

  (setq *key-press-hook* (lambda (key key-seq command-value)
                           (message
                            (format nil "key pressed: ~S, ~S, ~S" key key-seq command-value)
                            )))
  (define-key *top-map* (kbd "quoteleft") "gcycle")
  (lookup-key *top-map* (kbd "quoteleft"))
  (lookup-command *top-map* "gcycle")

  (type-of (kbd "quoteleft"))
  (class-of (kbd "quoteleft"))

  (car *group-cycle-stack*)

  (list-groups)

  (string-equal *last-command* "gother")
  ;; (mapcan )

  (merge-groups (find-group (current-screen) "www") (find-group (current-screen) "asd"))

  (map 'list (lambda (g)
               (list (format-expand *group-formatters* *group-format* g) g))
       (screen-groups (current-screen)))

  (get-command-structure "grouplist")

  (format nil "~A ~&" "as" "asd")

  (map nil
       (lambda (i)
         (progn
           (message (format nil "defining ~A" i))
           ;; (define-key *top-map*
           ;;     (kbd (format nil "s-F~A" i))
           ;;   (format nil "gselect ~A" i))
           ))
       (concatenate 'list (loop for i from 1 to 10
                             collect i) "-" "="))

  )


;;; misc

;; reinitialize group names
#+nil
(let* ((current-groups (sort-groups (current-screen))))
  (reduce (lambda (idx name)
            (let* ((g (nth idx current-groups)))
              (progn
                (setf (group-name g) name)
                ;; (setf (group-name g) (format nil "~D" idx))
                (+ idx 1)
                ))) *default-groups* :initial-value 0))


;; ;; prompt the user for an interactive command. The first arg is an
;; ;; optional initial contents.
;; (defcommand colon1 (&optional (initial "")) (:rest)
;;   (let ((cmd (read-one-line (current-screen) ": " :initial-input initial)))
;;     (when cmd
;;       (eval-command cmd t))))

;; ;; Message window font
;; (set-font "-xos4-terminus-medium-r-normal--14-140-72-72-c-80-iso8859-15")

;; ;;; Define window placement policy...

;; ;; Clear rules
;; (clear-window-placement-rules)

;; ;; Last rule to match takes precedence!
;; ;; TIP: if the argument to :title or :role begins with an ellipsis, a substring
;; ;; match is performed.
;; ;; TIP: if the :create flag is set then a missing group will be created and
;; ;; restored from *data-dir*/create file.
;; ;; TIP: if the :restore flag is set then group dump is restored even for an
;; ;; existing group using *data-dir*/restore file.
;; (define-frame-preference "Default"
;;   ;; frame raise lock (lock AND raise == jumpto)
;;   (0 t nil :class "Konqueror" :role "...konqueror-mainwindow")
;;   (1 t nil :class "XTerm"))

;; (define-frame-preference "Ardour"
;;   (0 t   t   :instance "ardour_editor" :type :normal)
;;   (0 t   t   :title "Ardour - Session Control")
;;   (0 nil nil :class "XTerm")
;;   (1 t   nil :type :normal)
;;   (1 t   t   :instance "ardour_mixer")
;;   (2 t   t   :instance "jvmetro")
;;   (1 t   t   :instance "qjackctl")
;;   (3 t   t   :instance "qjackctl" :role "qjackctlMainForm"))

;; (define-frame-preference "Shareland"
;;   (0 t   nil :class "XTerm")
;;   (1 nil t   :class "aMule"))

;; (define-frame-preference "Emacs"
;;   (1 t t :restore "emacs-editing-dump" :title "...xdvi")
;;   (0 t t :create "emacs-dump" :class "Emacs"))