1 ;;; framemove.el --- directional frame selection routines
5 ;; Author: Trey Jackson (bigfaceworm@gmail.com)
6 ;; Created: February 14, 2010
7 ;; Keywords: frame, movement, convenience
9 ;; This file is not (yet) a part of GNU Emacs.
11 ;; Very much like the windmove package, only for frames.
12 ;; Provide a simple set of keystrokes to move the input/focus
17 ;; This software is licensed under the GPL version 3.
20 ;; (require 'framemove)
21 ;; (framemove-default-keybindings)
23 ;; If you want to integrate framemove and windmove
24 ;; You can omit the call to 'framemove-default-keybindings
26 ;; (require 'framemove)
27 ;; (windmove-default-keybindings)
28 ;; (setq framemove-hook-into-windmove t)
30 ;; Compatibility: GNU Emacs 22.x, 23.x
33 (defvar framemove-hook-into-windmove nil
34 "When non-nil, try moving frames if moving windows fails.")
36 (defun fm-frame-bbox (frame)
37 ;; eval b/c when things are beyond borders, you get
39 (let ((yl (eval (frame-parameter frame 'top)))
40 (xl (eval (frame-parameter frame 'left))))
43 (+ xl (frame-pixel-width frame))
44 (+ yl (frame-pixel-height frame)))))
46 (defun fm-opposite (dir)
47 (cdr (assq dir '((left . right) (right . left) (up . down) (down . up)))))
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)
55 (defun fm-frame-is-completly-to-dir-of (refframe dir otherframe)
57 ((eq refframe otherframe)
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))))
65 (defun fm-frame-is-to-dir-of (refframe dir otherframe)
67 ((not (eq (frame-parameter refframe 'display) (frame-parameter otherframe 'display)))
69 ((eq refframe otherframe)
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))))
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)))))
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)))))
91 (defun fm-project (coord frame dir)
92 "project COORD in direction DIR to edge of FRAME"
93 (if (memq dir '(up down))
95 (fm-frame-coord frame dir))
96 (cons (fm-frame-coord frame dir)
100 (defun fm-next-frame (dir)
101 "move focus to next frame in direction (from currently focused frame)"
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))
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)))))
114 (let ((frames-in-line-of-cursor
115 ;; try to find frame in line with cursor
117 '(lambda (f) (fm-coord-in-range current-coords dir f))
119 (frames-in-line-of-frame
120 ;; find frame that overlaps current frame
121 ;; need to sort by distance from cursor
124 '(lambda (f) (fm-range-overlap thisframe f dir))
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"))))
135 (defun fm-dist-from-coords (coord frame)
136 "distance from coord to the bbox of the frame"
137 (let* ((x (car 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)
151 ((sqrt (+ (expt x-dist 2)
152 (expt y-dist 2)))))))
154 (defun fm-v-in-range (v range)
155 (and (> v (car range))
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))))
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)))))
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))))
184 (defun fm-sort-frames-by-edge (framelist dir)
188 (apply (symbol-function
189 (if (memq dir '(left up)) '> '<))
190 (list (fm-frame-coord f1 dir) (fm-frame-coord f2 dir))))))
193 (defun fm-down-frame ()
195 (fm-next-frame 'down))
197 (defun fm-up-frame ()
201 (defun fm-left-frame ()
203 (fm-next-frame 'left))
205 (defun fm-right-frame ()
207 (fm-next-frame 'right))
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."
215 (unless modifier (setq modifier 'meta))
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))
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."
227 (if framemove-hook-into-windmove
228 (fm-next-frame (ad-get-arg 0))
229 (error (error-message-string err))))))
232 ;;; framemove.el ends here