drag.el

(require 'cl)

(defmacro ignore-errors (error-symbols &rest body)
  `(condition-case nil
       (progn ,@body)
       ,@(loop for error-symbol in error-symbols
               collect `(,error-symbol nil))))

(defmacro swap (x y)
  (let ((temp (gensym)))
    `(let ((,temp ,x))
       (setq ,x ,y)
       (setq ,y ,temp))))

(defun in-region-p (x lo hi)
  (and (<= lo x) (< x hi)))

(defun swap-regions (startr1 endr1 startr2 endr2)
  (let ((region2 (delete-and-extract-region startr2 endr2)))
    (goto-char startr2)
    (insert (delete-and-extract-region startr1 endr1))
    (goto-char startr1)
    (insert region2)))

(defun swap-regions-and-point (startr1 endr1 startr2 endr2)
  (when (< startr2 startr1)
    (swap startr1 startr2)
    (swap endr1 endr2))
  (let* ((offset    (- (- endr2 startr2) (- endr1 startr1)))
         (new-point (cond ((in-region-p (point) startr1 endr1) (+ startr2 (- (point) startr1) offset))
                          ((in-region-p (point) startr2 endr2) (+ startr1 (- (point) startr2)))
                          (t                                   (point)))))
    (swap-regions startr1 endr1 startr2 endr2)
    (goto-char new-point)))

(defmacro save-point (&rest body)
  `(save-excursion ,@body (point)))

(defun drag (n next beginning end)
  (swap-regions-and-point (save-point (funcall beginning))
                          (save-point (funcall end))
                          (save-point (funcall next n) (funcall beginning))
                          (save-point (funcall next n) (funcall end))))

(defun beginning-of (forward backward)
  (let ((base-point (save-point (funcall backward) (funcall forward))))
    (when (or (= base-point (save-point (funcall forward)))
              (= base-point (point)))
      (funcall backward))))

(defun end-of (forward backward)
  (beginning-of backward forward))

(defun next-of (n forward beginning end)
  (if (>= n 0)
      (funcall forward (+ n (if (= (point) (save-point (funcall end))) 0 1)))
    (funcall forward (- n (if (= (point) (save-point (funcall beginning))) 0 1))))
  (funcall beginning))

(defmacro defdrag (name forward backward)
  (let ((beginning-of-symbol (intern (concat "beginning-of-" (symbol-name name))))
        (end-of-symbol       (intern (concat "end-of-" (symbol-name name))))
        (next-symbol         (intern (concat "next-" (symbol-name name))))
        (drag-symbol         (intern (concat "drag-" (symbol-name name)))))
    `(progn
       (defun ,beginning-of-symbol ()
         (interactive)
         (beginning-of ,forward ,backward))
       (defun ,end-of-symbol ()
         (interactive)
         (end-of ,forward ,backward))
       (defun ,next-symbol (n)
         (interactive "*p")
         (next-of n ,forward ',beginning-of-symbol ',end-of-symbol))
       (defun ,drag-symbol (n)
         (interactive "*p")
         (drag n ',next-symbol ',beginning-of-symbol ',end-of-symbol)))))

;; Default draggers

(defun drag-line (n)
  (interactive "*p")
  (drag n 'forward-line 'beginning-of-line 'end-of-line))

(defun drag-char (n)
  (interactive "*p")
  (drag n 'forward-char nil 'forward-char))

(defdrag word 'forward-word 'backward-word)
(defdrag sentence 'forward-sentence 'backward-sentence)

;; (defdrag paragraph
;;   (lambda (&optional n)
;;     (forward-paragraph (or n 1))
;;     (when (save-excursion (re-search-forward paragraph-separate nil t))
;;         (forward-char)))
;;   (lambda (&optional n)
;;     (backward-paragraph (or n 1))
;;     (when (save-excursion (re-search-forward paragraph-separate nil t)
;;         (backward-char)))))

(defdrag sexp
  (lambda (&optional n)
    (ignore-errors (scan-error)
      (forward-sexp (or n 1))))
  (lambda (&optional n)
    (ignore-errors (scan-error)
      (backward-sexp (or n 1)))))

;; Experiments