stumpwm/miscellaneous.lisp @ a65fd2691c94 default tip

(in-package :stumpwm-user)

(defcommand sane-hsplit () ()
  (hsplit)
  (move-focus :right))

(defcommand sane-vsplit () ()
  (vsplit)
  (move-focus :down))


(defcommand move-focus* (direction)
    ((:direction "Enter a direction: "))
  (labels ((in-float-p ()
             (typep (current-group) 'stumpwm::float-group))
           (focus-first-frame ()
             (unless (in-float-p)
               ;; After moving to a new group we don't know which frame is
               ;; focused, and unfortunately Stump doesn't give us a nice way to
               ;; say "focus the leftmost frame" so we'll just move the focus
               ;; a bunch of times and hope it's enough.  Sigh.
               (loop :repeat 15
                     :until (eql (current-frame)
                                 (progn (move-focus (ecase direction
                                                      (:left :right)
                                                      (:right :left)))
                                        (current-frame))))))
           (next-group ()
             (ecase direction
               (:right (gnext))
               (:left (gprev)))
             (focus-first-frame)))
    (unless (in-float-p)
      (banish))
    (if (in-float-p)
      (next-group)
      (let ((frame (current-frame)))
        (move-focus direction)
        (when (eql frame (current-frame))
          (next-group))))))

(defcommand toggle-current-mode-line () ()
  (toggle-mode-line (current-screen) (current-head)))

(defcommand toggle-stumptray () ()
  (run-commands "stumptray"))

(defcommand kill-and-remove () ()
  (run-commands "kill" "remove"))

(defcommand sleep-machine ()
    ()
  (hostcase
    ((:gro :juss)
     (run-shell-command "exec lock-screen")
     (run-shell-command "systemctl suspend"))
    (t (message "Not sleeping this machine for safety."))))

(defcommand copy-clhs-url (s)
    ((:string "Symbol: "))
  (run-shell-command (format nil "clhs --url 'http://www.lispworks.com/documentation/HyperSpec/' --quiet --open echon '~A' | pbcopy" s)))

(defcommand describe-window () ()
  (show-window-properties))

(defcached (weather :seconds 120) ()
  (losh:sh '("/home/sjl/src/dotfiles/lisp/bin/weather" "48105" "-H" "36") :result-type 'list))

(defcommand rain () ()
  (_ (weather)
    (mapcar (lambda (line) (ppcre:regex-replace " 1[0-9]:00 " line "^6\\&^*")) _)
    (message "~{~A~^~%~}" _)))

(defcommand mark (thing) ((:string "Mark: "))
  (run-shell-command (format nil "mark ~A" thing)))

(defcommand clear-notifications () ()
  (run-shell-command "dunstctl close-all"))

(defcommand start-vm () ()
  (echo "Starting VM.")
  (run-shell-command "/home/sjl/vms/run"))


(defcommand toggle-zoom-mute () ()
  (when-let-window (win "^Zoom Meeting.*")
    ;; Zoom stupidly won't accept the shortcut unless it's in focus
    (unless (eql (window-group win) (current-group))
      ;;        jesus            christ        stump just export switch-to-group come on
      (gselect (princ-to-string (group-number (window-group win)))))
    (focus-window win t)
    (meta (kbd "M-a"))))

(defcommand end-zoom () ()
  (when-let-window (win "^Zoom Meeting.*")
    (kill-window win)
    (message "Killed meeting")))


(defcommand ggo () ()
  (let* ((current-screen (current-screen))
         (current-group (stumpwm::screen-current-group current-screen))
         (all-groups (sort (copy-seq (screen-groups current-screen)) #'< :key #'group-number))
         (groups (mapcar (lambda (group)
                           (list (format nil "~2D~A~A"
                                         (group-number group)
                                         (if (eql current-group group) #\* #\space)
                                         (group-name group))
                                 group))
                         all-groups))
         (selected (select-from-menu current-screen groups)))
    (when selected (stumpwm::switch-to-group (second selected)))))

(defcommand grename-cwd () ()
  (when-let ((cwd (dwim-cwd)))
    (grename (pathname-name (pathname cwd)))))