;;; anchored-transpose.el --- Transposes a phrase around an anchor phrase

;; Copyright (C) 2004 Free Software Foundation, Inc.

;; Author: Rick Bielawski <rbielaws@i1.net>
;; Keywords: tools convenience

;; This file is free software; you can redistribute it and/or modify it under
;; the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 2, or (at your option) any later
;; version.

;; This file is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
;; more details.

;;; Commentary:

;; `anchored-transpose' is an interactive autoload function to transpose
;; portions of a region around an anchor phrase.  In other words it swaps
;; two regions.
;;
;; See C-h f anchored-transpose <ret> for a complete description.

;;; Installing:

;; 1) Put anchored-transpose.el on your load path.
;; 2) Put the following 2 lines in your .emacs
;;    (global-set-key [?\C-x ?t] 'anchored-transpose) ;; Just a suggestion...
;;    (autoload 'anchored-transpose "anchored-transpose" nil t)

;;; History:

;; 2004-09-24 RGB Seems useable enough to release.
;; 2004-10-15 RGB Only comments and doc strings were updated.
;; 2004-10-22 RGB Added support for 2 phrase selection.
;; 2004-12-01 RGB Added secondary selection support.
;; 2005-07-21 RGB Updated help text and comments.
;;                Added support for A  C B  D and C  A D  B selection.
;;                Fixed bug affecting multi line selections.
;; 2005-09-28 RGB Allow swapping regions with no anchor text between.

;; Changes by Lennart Borgman
;; 2009-11-25 LB  Set and clear secondary selection from keyboard.
;;                Always use secondary selection.
;;                Keep selections right after swapping.
;;                Clear them if not used again.
;;                Swap between buffers.
;;                Check for read-only.
;;                Probably broke something... ;-)

;;; Code:

(defvar anchored-transpose-anchor ()
  "begin/end when `anchored-transpose' is in progress else nil")

;;;###autoload
(defun anchored-transpose (beg1 end1 flg1 &optional beg2 end2 flg2 win2)
  "Transpose portions of the region around an anchor phrase.

`this phrase but not that word'    can be transposed into
`that word but not this phrase'

I want this phrase but not that word.
       |----------------------------|. .This is the entire phrase.
                  |-------|. . . . . . .This is the anchor phrase.

First select the entire phrase and type \\[anchored-transpose].
This set the secondary selection.

Then select the anchor phrase and type \\[anchored-transpose]
again.  Alternatively you can do the selections like this:

I want this phrase but not that word.
       |----------|       |---------|   Separate phrase selection.

By default the anchor phrase will automatically include
any surrounding whitespace even if you don't explicitly select
it.  Also, it won't include certain trailing punctuation.  See
`anchored-transpose-do-fuzzy' for details.  A prefix arg prior to
either selection means `no fuzzy logic, use selections
literally'.

You can select the regions to be swapped separately in any
order.

After swapping both primary and secondary selection are still
active.  They will be canceled after second next command if you
do not swap regions again.  \(Second because this allow you to
adjust the regions and try again.)

You can also swap text between different buffers this way.

Typing \\[anchored-transpose] with nothing selected clears any
prior selection, ie secondary selection."
  (interactive `(,(region-beginning) ,(region-end)
                 ,current-prefix-arg
                 ,@anchored-transpose-anchor))
  (setq anchored-transpose-anchor nil)
  (when (and mouse-secondary-overlay
             mark-active
             (overlay-buffer mouse-secondary-overlay)
             (/= (overlay-start mouse-secondary-overlay)
                 (overlay-end mouse-secondary-overlay)))
    (if (eq (overlay-buffer mouse-secondary-overlay) (current-buffer))
        (progn
          (setq beg2 (overlay-start mouse-secondary-overlay))
          (setq end2 (overlay-end mouse-secondary-overlay))
          (setq flg2 flg1)
          (delete-overlay mouse-secondary-overlay))
      (let* ((sec-buf (overlay-buffer mouse-secondary-overlay))
             (sec-win (get-buffer-window sec-buf))
             (sec-new nil))
        (unless sec-win
          (setq sec-new t)
          (setq sec-win (split-window)))
        (with-selected-window sec-win
          (set-window-buffer (selected-window) sec-buf)
          (goto-char (overlay-start mouse-secondary-overlay)))
        (if (not (y-or-n-p "Swap between buffers "))
            (when sec-new (delete-window sec-win))
          (setq beg2 (overlay-start mouse-secondary-overlay))
          (setq end2 (overlay-end mouse-secondary-overlay))
          (setq flg2 flg1)
          (setq win2 sec-win)))))
  (setq win2 (or win2 (selected-window)))
  (if mark-active
      (if end2                     ; then both regions are marked.  swap them.
          (if (not (eq win2 (selected-window)))
              (anchored-transpose-swap beg1 end1 beg2 end2 win2)
            (if (and (< beg1 beg2)        ;A  C B  D
                     (< end1 end2)
                     (> end1 beg2))
                (apply 'anchored-transpose-swap
                       (anchored-transpose-do-fuzzy
                        beg1 beg2 end1 end2 flg1 flg2 flg1 flg2))
              (if (and (> beg1 beg2)      ;C  A D  B
                       (> end1 end2)
                       (> end2 beg1))
                  (apply 'anchored-transpose-swap
                         (anchored-transpose-do-fuzzy
                          beg2 beg1 end2 end1 flg2 flg1 flg2 flg1))
                (if (and (< beg1 beg2)    ;A  C D  B
                         (> end1 end2))
                    (apply 'anchored-transpose-swap
                           (anchored-transpose-do-fuzzy
                            beg1 beg2 end2 end1 flg1 flg2 flg2 flg1))
                  (if (and (> beg1 beg2)  ;C  A B  D
                           (< end1 end2))
                      (apply 'anchored-transpose-swap
                             (anchored-transpose-do-fuzzy
                              beg2 beg1 end1 end2 flg2 flg1 flg1 flg2))
                    (if (<= end1 beg2)    ;A B  C D
                        (apply 'anchored-transpose-swap
                               (anchored-transpose-do-fuzzy
                                beg1 end1 beg2 end2 flg1 flg1 flg2 flg2))
                      (if (<= end2 beg1)  ;C D A B
                          (apply 'anchored-transpose-swap
                                 (anchored-transpose-do-fuzzy
                                  beg2 end2 beg1 end1 flg2 flg2 flg1 flg1))
                        (error "Regions have invalid overlap"))))))))
        ;; 1st of 2 regions.  Save it and wait for the other.
        ;;(setq anchored-transpose-anchor (list beg1 end1 flg1))
        (if (or buffer-read-only
                (get-char-property beg1 'read-only)
                (get-char-property end1 'read-only))
            ;; Fix-me: move test, clean up a bit.
            (message "Buffer text is readonly")
          (set-secondary-selection beg1 end1)
          (setq deactivate-mark t)
          (message "%s" (this-command-keys))
          (message (propertize "Transpose: Select second region and call again - (without selection to cancel)"
                               'face 'secondary-selection))))
    (if (and mouse-secondary-overlay
             (overlay-buffer mouse-secondary-overlay))
        (progn
          (cancel-secondary-selection)
          (message (propertize "Canceled secondary selection" 'face
                               'highlight)))
      (message (propertize "Command requires a marked region" 'face
                           'highlight)))))

;;;###autoload
(defun set-secondary-selection (beg end)
  "Set the secondary selection to the current region.
This must be bound to a mouse drag event."
  (interactive "r")
  (move-overlay mouse-secondary-overlay beg end (current-buffer))
  (when (called-interactively-p 'interactive)
    ;;(deactivate-mark)
    )
  (x-set-selection
   'SECONDARY
   (buffer-substring (overlay-start mouse-secondary-overlay)
                     (overlay-end mouse-secondary-overlay))))

;;;###autoload
(defun cancel-secondary-selection ()
  (interactive)
  (delete-overlay mouse-secondary-overlay)
  (x-set-selection 'SECONDARY nil))

(defun anchored-transpose-do-fuzzy (r1beg r1end r2beg r2end
                                          lit1 lit2 lit3 lit4)
  "Returns the first 4 arguments after adjusting their value if necessary.

I want this phrase but not that word.
       |----------------------------|. .This is the entire phrase.
                  |-------|. . . . . . .This is the anchor phrase.
     R1BEG      R1END   R2BEG     R2END

R1BEG and R1END define the first region and R2BEG and R2END the second.

The flags, LIT1 thru LIT4 indicate if fuzzy logic should be applied to the
beginning of R1BEG, the end of R1END, the beginning of R2BEG, the end of R2END
respectively.  If any flag is nil then fuzzy logic will be applied.  Otherwise
the value passed should be returned LITerally (that is, unchanged).

See `anchored-transpose-fuzzy-begin' and `anchored-transpose-fuzzy-end' for
specifics on what adjustments these routines will make when LITx is nil."
  (list
   (if lit1 r1beg
     (anchored-transpose-fuzzy-begin r1beg r1end "[\t ]+"))
   (if lit2 r1end
     (anchored-transpose-fuzzy-end   r1beg r1end "\\s +"))
   (if lit3 r2beg
     (anchored-transpose-fuzzy-begin r2beg r2end "[\t ]+"))
   (if lit4 r2end
     (anchored-transpose-fuzzy-end   r2beg r2end "\\s *[.!?]"))
   nil))

(defun anchored-transpose-fuzzy-end (beg end what)
  "Returns END or new value for END based on the regexp WHAT.
BEG and END are buffer positions defining a region.  If that region ends
with WHAT then the value for END is adjusted to exclude that matching text.

NOTE: The regexp is applied differently than `looking-back' applies a regexp.

Example: if (buffer-string beg end) contains `1234' the regexp `432' matches
it, not `234' as `looking-back' would.  Also, your regexp never sees the char
at BEG so the match will always leave at least 1 character to transpose.
The reason for not using looking-back is that it's not greedy enough.
\(looking-back \" +\") will only match one space no matter how many exist."
  (let ((str (concat
              (reverse (append (buffer-substring (1+ beg) end) nil)))))
    (if (string-match (concat "`" what) str)
        (- end (length (match-string 0 str)))
      end)))

(defun anchored-transpose-fuzzy-begin (beg end what)
  "Returns BEG or a new value for BEG based on the regexp WHAT.
BEG and END are buffer positions defining a region.  If the region begins
with WHAT then BEG is adjusted to exclude the matching text.

NOTE: Your regexp never sees the last char defined by beg/end.  This insures
at least 1 char is always left to transpose."
  (let ((str (buffer-substring beg (1- end))))
    (if (string-match (concat "`" what) str)
        (+ beg (length (match-string 0 str)))
      beg)))

(defun anchored-transpose-swap (r1beg r1end r2beg r2end win2)
  "Swaps region r1beg/r1end with r2beg/r2end. Flags are currently ignored.
Point is left at r1end."
  (let ((reg1 (buffer-substring r1beg r1end))
        (reg2 nil)
        (old-buffer (current-buffer)))
    (when win2
      (unless (eq (selected-window) win2)
        (select-window win2)
        (set-buffer (window-buffer (selected-window)))))
    (setq reg2 (delete-and-extract-region r2beg r2end))
    (goto-char r2beg)
    (let ((new-mark (point)))
      (insert reg1)
      (push-mark new-mark))
    ;; I want to leave point at the end of phrase 2 in current buffer.
    (save-excursion
      (with-current-buffer old-buffer
        (goto-char r1beg)
        (delete-region r1beg r1end)
        (let ((here (point)))
          (insert reg2)
          (set-secondary-selection here (point)))))
    (setq deactivate-mark nil)
    (when (eq old-buffer (current-buffer))
      (add-hook 'post-command-hook 'anchored-swap-post-command t t))))

(defun anchored-swap-post-command ()
  (condition-case err
      (unless mark-active
        (cancel-secondary-selection)
        (remove-hook 'post-command-hook 'anchored-swap-post-command t))
    (error (message "anchored-swap-post-command: %s" err))))

(provide 'anchored-transpose)

;; Because I like it this way.  So there!
;;; fill-column:78 ***
;;; emacs-lisp-docstring-fill-column:78 ***
;;;
;;; Local Variables: ***
;;; End: ***
;;; anchored-transpose.el ends here.