auto-install/framemove.el

   1 ;;; framemove.el --- directional frame selection routines
   2 ;;
   3 ;; Copyright (C) 2010
   4 ;;
   5 ;; Author: Trey Jackson (bigfaceworm@gmail.com)
   6 ;; Created: February 14, 2010
   7 ;; Keywords: frame, movement, convenience
   8 ;;
   9 ;; This file is not (yet) a part of GNU Emacs.
  10 ;;
  11 ;; Very much like the windmove package, only for frames.
  12 ;; Provide a simple set of keystrokes to move the input/focus
  13 ;; between windows.
  14 ;;
  15 ;; Version 0.9
  16 ;;
  17 ;; This software is licensed under the GPL version 3.
  18 ;;
  19 ;; To install:
  20 ;;   (require 'framemove)
  21 ;;   (framemove-default-keybindings)
  22 ;;
  23 ;; If you want to integrate framemove and windmove
  24 ;; You can omit the call to 'framemove-default-keybindings
  25 ;; And instead do:
  26 ;;    (require 'framemove)
  27 ;;    (windmove-default-keybindings)
  28 ;;    (setq framemove-hook-into-windmove t)
  29 ;;
  30 ;; Compatibility: GNU Emacs 22.x, 23.x
  31 ;;
  32
  33 (defvar framemove-hook-into-windmove nil
  34   "When non-nil, try moving frames if moving windows fails.")
  35
  36 (defun fm-frame-bbox (frame)
  37   ;; eval b/c when things are beyond borders, you get
  38   ;; (+ -11) weirdness
  39   (let ((yl (eval (frame-parameter frame 'top)))
  40         (xl (eval (frame-parameter frame 'left))))
  41     (list xl
  42           yl
  43           (+ xl (frame-pixel-width frame))
  44           (+ yl (frame-pixel-height frame)))))
  45
  46 (defun fm-opposite (dir)
  47   (cdr (assq dir '((left . right) (right . left) (up . down) (down . up)))))
  48
  49 (defun fm-frame-coord (frame-or-box dir)
  50   (nth (cdr (assq dir '((left . 0) (up . 1) (right . 2) (down . 3))))
  51        (if (framep frame-or-box)
  52            (fm-frame-bbox frame-or-box)
  53          frame-or-box)))
  54
  55 (defun fm-frame-is-completly-to-dir-of (refframe dir otherframe)
  56   (cond
  57    ((eq refframe otherframe)
  58     nil)
  59    ((memq dir '(left up))
  60     (< (fm-frame-coord refframe (fm-opposite dir)) (fm-frame-coord otherframe dir)))
  61    ((memq dir '(right down))
  62     (> (fm-frame-coord refframe (fm-opposite dir)) (fm-frame-coord otherframe dir)))
  63    (t (error "Invalid direction of movement: %s" dir))))
  64
  65 (defun fm-frame-is-to-dir-of (refframe dir otherframe)
  66   (cond
  67    ((not (eq (frame-parameter refframe 'display) (frame-parameter otherframe 'display)))
  68       nil)
  69    ((eq refframe otherframe)
  70     nil)
  71    ((memq dir '(left up))
  72     (< (fm-frame-coord refframe dir) (fm-frame-coord otherframe dir)))
  73    ((memq dir '(right down))
  74     (> (fm-frame-coord refframe dir) (fm-frame-coord otherframe dir)))
  75    (t (error "Invalid direction of movement: %s" dir))))
  76
  77 (defun fm-absolute-coords-of-position (position)
  78   (let ((rel-x-y (fm-frame-relative-coordinates position))
  79         (frame-bbox (fm-frame-bbox (window-frame (posn-window position)))))
  80     (cons (+ (car frame-bbox) (car rel-x-y))
  81           (+ (cadr frame-bbox) (cdr rel-x-y)))))
  82
  83 (defun fm-frame-relative-coordinates (position)
  84   "Return frame-relative coordinates from POSITION."
  85   (let* ((x-y (posn-x-y position))
  86          (window (posn-window position))
  87          (edges (window-inside-pixel-edges window)))
  88     (cons (+ (car x-y) (car edges))
  89           (+ (cdr x-y) (cadr edges)))))
  90
  91 (defun fm-project (coord frame dir)
  92   "project COORD in direction DIR to edge of FRAME"
  93   (if (memq dir '(up down))
  94       (cons (car coord)
  95             (fm-frame-coord frame dir))
  96     (cons (fm-frame-coord frame dir)
  97           (cdr coord))))
  98
  99
 100 (defun fm-next-frame (dir)
 101   "move focus to next frame in direction (from currently focused frame)"
 102   (interactive (list
 103                 (intern (completing-read "Which direction: " '("up" "down" "left" "right") nil t))))
 104   (let* ((thisframe (selected-frame))
 105          (current-coords (fm-absolute-coords-of-position (posn-at-point)))
 106          (coords-projected-in-dir (fm-project current-coords thisframe dir))
 107          (possible-frames
 108           (sort
 109            (remove-if-not
 110             '(lambda (f) (fm-frame-is-to-dir-of f dir thisframe))
 111             (visible-frame-list))
 112            '(lambda (f1 f2) (fm-frame-is-to-dir-of f1 (fm-opposite dir) f2)))))
 113     (if possible-frames
 114         (let ((frames-in-line-of-cursor
 115                ;; try to find frame in line with cursor
 116                (remove-if-not
 117                 '(lambda (f) (fm-coord-in-range current-coords dir f))
 118                 possible-frames))
 119               (frames-in-line-of-frame
 120                ;; find frame that overlaps current frame
 121                ;; need to sort by distance from cursor
 122                (sort
 123                 (remove-if-not
 124                  '(lambda (f) (fm-range-overlap thisframe f dir))
 125                  possible-frames)
 126                 '(lambda (f1 f2)
 127                    (< (fm-dist-from-coords coords-projected-in-dir f1)
 128                       (fm-dist-from-coords coords-projected-in-dir f2))))))
 129           (select-frame-set-input-focus
 130            (or (car frames-in-line-of-cursor)
 131                (car frames-in-line-of-frame)
 132                (car possible-frames))))
 133       (error "No frame in that direction"))))
 134
 135 (defun fm-dist-from-coords (coord frame)
 136   "distance from coord to the bbox of the frame"
 137   (let* ((x (car coord))
 138          (y (cdr coord))
 139          (x-in-range (fm-v-in-range x (fm-bbox-range 'left frame)))
 140          (y-in-range (fm-v-in-range y (fm-bbox-range 'up frame)))
 141          (x-dist (min (abs (- x (fm-frame-coord frame 'left)))
 142                       (abs (- x (fm-frame-coord frame 'right)))))
 143          (y-dist (min (abs (- y (fm-frame-coord frame 'up)))
 144                       (abs (- y (fm-frame-coord frame 'down))))))
 145     (cond ((and x-in-range y-in-range)
 146            0)
 147           (x-in-range
 148            y-dist)
 149           (y-in-range
 150            x-dist)
 151           ((sqrt (+ (expt x-dist 2)
 152                     (expt y-dist 2)))))))
 153
 154 (defun fm-v-in-range (v range)
 155   (and (> v (car range))
 156        (< v (cdr range))))
 157
 158 (defun fm-bbox-range (dir box)
 159   (if (memq dir '(up down))
 160       (cons (fm-frame-coord box 'up)
 161             (fm-frame-coord box 'down))
 162     (cons (fm-frame-coord box 'left)
 163           (fm-frame-coord box 'right))))
 164
 165 (defun fm-range-overlap (f1 f2 dir)
 166   "return true if the bbox'es of the two frames overlap using coords perpendicular to dir"
 167   (let ((perp (if (memq dir '(up down)) 'left 'up))
 168         (f1box (fm-frame-bbox f1))
 169         (f2box (fm-frame-bbox f2)))
 170     (or (fm-v-in-range (fm-frame-coord f1 perp) (fm-bbox-range perp f2))
 171         (fm-v-in-range (fm-frame-coord f1 (fm-opposite perp)) (fm-bbox-range perp f2))
 172         (fm-v-in-range (fm-frame-coord f2 perp) (fm-bbox-range perp f1))
 173         (fm-v-in-range (fm-frame-coord f2 (fm-opposite perp)) (fm-bbox-range perp f1)))))
 174
 175 (defun fm-coord-in-range (coord dir frame)
 176   "return true if the coord can be projected in orientation of dir
 177 onto the bbox of the frame, or more simply, is the part of the coord
 178 perpendicular to DIR between the edges of frame perpendicular to DIR"
 179   (let ((n (if (memq dir '(up down)) (car coord) (cdr coord)))
 180         (perp (if (memq dir '(up down)) 'left 'up)))
 181     (and (< (fm-frame-coord frame perp) n)
 182          (> (fm-frame-coord frame (fm-opposite perp)) n))))
 183
 184 (defun fm-sort-frames-by-edge (framelist dir)
 185   (sort
 186    framelist
 187    (lambda (f1 f2)
 188      (apply (symbol-function
 189              (if (memq dir '(left up)) '> '<))
 190             (list (fm-frame-coord f1 dir) (fm-frame-coord f2 dir))))))
 191
 192 ;;;###autoload
 193 (defun fm-down-frame ()
 194   (interactive)
 195   (fm-next-frame 'down))
 196 ;;;###autoload
 197 (defun fm-up-frame ()
 198   (interactive)
 199   (fm-next-frame 'up))
 200 ;;;###autoload
 201 (defun fm-left-frame ()
 202   (interactive)
 203   (fm-next-frame 'left))
 204 ;;;###autoload
 205 (defun fm-right-frame ()
 206   (interactive)
 207   (fm-next-frame 'right))
 208
 209 ;;;###autoload
 210 (defun framemove-default-keybindings (&optional modifier)
 211   "Set up keybindings for `framemove'.
 212 Keybindings are of the form MODIFIER-{left,right,up,down}.
 213 Default MODIFIER is 'meta."
 214   (interactive)
 215   (unless modifier (setq modifier 'meta))
 216
 217   (global-set-key (vector (list modifier 'down))  'fm-down-frame)
 218   (global-set-key (vector (list modifier 'up))    'fm-up-frame)
 219   (global-set-key (vector (list modifier 'left))  'fm-left-frame)
 220   (global-set-key (vector (list modifier 'right)) 'fm-right-frame))
 221
 222 (defadvice windmove-do-window-select (around framemove-do-window-select-wrapper activate)
 223   "Let windmove do its own thing, if there is an error, try framemove in that direction."
 224   (condition-case err
 225       ad-do-it
 226     (error
 227      (if framemove-hook-into-windmove
 228          (fm-next-frame (ad-get-arg 0))
 229        (error (error-message-string err))))))
 230
 231 (provide 'framemove)
 232 ;;; framemove.el ends here