Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 102 lines (86 sloc) 3.768 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
(define-structure throw-window
    (export throw-window-right
            throw-window-left
            throw-window-up
            throw-window-down)
  (open rep sawfish.wm)

  (defun reduce (fn initial list)
    (fn initial
        (if (cdr list)
          (reduce fn (car list) (cdr list))
          (car list))))

  (defun x-coord (pair) (car pair))
  (defun y-coord (pair) (cdr pair))

  (defun stops-for (coord far-edge)
    (let* ((windows (managed-windows))
           (pairs (mapcar
                   (lambda (w)
                     (let ((offset (coord (window-position w)))
                           (size (coord (window-frame-dimensions w))))
                       (list offset (+ offset size))))
                   windows)))
      (sort (filter (lambda (x) (<= x far-edge))
                    (uniquify-list (cons far-edge (apply append pairs))))
            #'<)))

  (defun horiz-stops (max-x) (stops-for #'x-coord max-x))
  (defun vert-stops (max-y) (stops-for #'y-coord max-y))
  
  (defun next-stop (stops current)
    (if stops
        (if (> (car stops) current)
            (car stops)
            (next-stop (cdr stops) current))))
  
  (defun previous-stop (stops current)
    (cond ((not (cadr stops)) (car stops))
          ((>= (cadr stops) current) (car stops))
          (t (previous-stop (cdr stops) current))))
  
  (defun previous-stop-for (fn point)
    (let* ((value (fn point))
           (stops (stops-for fn value)))
      (previous-stop stops value)))

  (defun find-far-edge (co-ord property-index)
    (- (co-ord (current-head-dimensions))
       2
       (reduce + 0
               (mapcar (lambda (w)
                         (let ((p (get-x-property w '_NET_WM_STRUT_PARTIAL))
                               (p1 (get-x-property w '_NET_WM_STRUT)))
                           (if (or p p1)
                               (aref (caddr (or p p1)) 3)
                               0)))
                       (managed-windows)))))
  
  (defun find-bottom-edge () (find-far-edge y-coord 3))
  (defun find-right-edge () (find-far-edge x-coord 1))

  (defun do-move (w x y)
    (let* ((mousexy (query-pointer))
           (frame-offset (window-frame-offset w))
           (windowxy (window-position w))
           (offset (cons (+ (car frame-offset) (- (car mousexy) (car windowxy)))
                         (+ (cdr frame-offset) (- (cdr mousexy) (cdr windowxy))))))
      (move-window-to w x y)
      (warp-cursor-to-window w (car offset) (cdr offset))
      (raise-window w)))
  
  (defun throw-window-right (window)
    (let* ((dim (window-frame-dimensions window))
           (xy (window-position window))
           (edge (- (find-right-edge) (x-coord dim)))
           (stop (next-stop (stops-for #'x-coord edge) (x-coord xy))))
      (do-move window stop (cdr xy))))

  (defun throw-window-down (window)
    (let* ((dim (window-frame-dimensions window))
           (xy (window-position window))
           (edge (- (find-bottom-edge) (y-coord dim)))
           (stop (next-stop (stops-for #'y-coord edge) (y-coord xy))))
      (do-move window (car xy) stop)))

  (defun throw-window-left (window)
    (let* ((xy (window-position window))
           (new-x (previous-stop-for #'x-coord xy)))
      (do-move window new-x (cdr xy))))

  (defun throw-window-up (window)
    (let* ((xy (window-position window))
           (new-y (previous-stop-for #'y-coord xy)))
      (do-move window (car xy) new-y)))
  
  (define-command 'throw-focused-window-right throw-window-right #:spec "%f")
  (define-command 'throw-focused-window-left throw-window-left #:spec "%f")
  (define-command 'throw-focused-window-top throw-window-up #:spec "%f")
  (define-command 'throw-focused-window-bottom throw-window-down #:spec "%f")
)
Something went wrong with that request. Please try again.