;;; xxx.el --- C-xC-x(`exchange-point-and-mark') extension

;; Copyright (C) 2004  Taiki SUGAWARA <taiki.s@cityfujisawa.ne.jp>

;; Author: Taiki SUGAWARA <taiki.s@cityfujisawa.ne.jp>
;; Keywords: mark

;; 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Installation:
;; If you replace `exchange-point-and-mark' to `xxx', write following code
;; into your .emacs file.
;;	(require 'xxx)
;;	(substitute-key-definition 'exchange-point-and-mark 'xxx (current-global-map))

;; This package is expand forward and backward region when exchange-point-and-mark.
;; If you type M-x xxx (or C-xC-x), point and mark is exchanged.
;; Next, If you type C-r, region is expand to previous mark of mark-ring.
;; Similarly, If you type C-s, region is expand to nect mark of mark-ring.

;; This package is useful that situation, run isearch 2nd time, and you wish
;; kill between first isearch position and current posintion.

;; インストール:
;; `exchange-point-and-mark' と `xxx' を入れかえたかったら以下を .emacs に書け
;; ばいい。
;;	(require 'xxx)
;;	(substitute-key-definition 'exchange-point-and-mark 'xxx (current-global-map))

;; このパッケージは、`exchange-point-and-mark' をしたときに、region をさらに前
;; や後にのばしてくれる。
;; たとえば、M-x xxx (または C-xC-x) して、C-r を打つと、region が mark-ring
;; にある手前の位置の mark までひろがる。
;; 同じように、M-x xxx して、C-s を打つと、region が mark-ring にある後ろの位
;; 置の mark までひろがる。

;; isearch を２回くらいやった後に、最初に isearch した位置と今の位置を kill し
;; たいとか、そういう時に便利。

;;; Code:

(eval-when-compile
  (require 'cl))

(defvar xxx-mark-ring nil)
(defvar xxx-original-point nil)
(defvar xxx-original-mark nil)
(defvar xxx-original-transient-mark-mode nil)

(defvar xxx-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-s" 'xxx-goto-next-mark)
    (define-key map "\C-r" 'xxx-goto-previous-mark)
    (define-key map "\C-m" 'xxx-exit)
    (define-key map "\C-q" 'xxx-restore-and-quit)
    (define-key map "\C-g" 'xxx-quit)
    (define-key map "\C-x\C-x" 'exchange-point-and-mark)
    map)
  "Keymap that use running xxx.")
  
(defun xxx ()
  "Start C-xC-x(`exchange-point-and-mark') extension."
  (interactive)
  (setq xxx-mark-ring (xxx-delete-duplicate-mark-ring
		       (cons (point-marker) mark-ring)))
  (setq xxx-original-point (point))
  (setq xxx-original-mark (mark t))
  (setq xxx-original-transient-mark-mode transient-mark-mode)
  (setq transient-mark-mode t)
  (add-hook 'pre-command-hook 'xxx-pre-command-hook)
  (exchange-point-and-mark)
  (xxx-mode 1))
  
(define-minor-mode xxx-mode
  "XXX minor mode.
This is call from `xxx'. Don't call yourself."
  nil
  "XXX"
  xxx-mode-map)

(defun xxx-pre-command-hook ()
  (unless (delq nil (mapcar (lambda (x) (rassq this-command x))
			    (accessible-keymaps xxx-mode-map)))
    (xxx-exit)))

(defun xxx-goto-next-mark ()
  "Goto next mark.
And expand region to that position."
  (interactive)
  (let ((mark (xxx-search-next-mark (point) xxx-mark-ring)))
    (when mark
      (exchange-point-and-mark)
      (set-mark (marker-position mark))
      (exchange-point-and-mark))))

(defun xxx-goto-previous-mark ()
  "Goto previous mark.
And expand region to that position."
  (interactive)
  (let ((mark (xxx-search-previous-mark (point) xxx-mark-ring)))
    (when mark
      (exchange-point-and-mark)
      (set-mark (marker-position mark))
      (exchange-point-and-mark))))

(defun xxx-exit ()
  "Exit `xxx'."
  (interactive)
  (xxx-mode -1)
  (remove-hook 'pre-command-hook 'xxx-pre-command-hook)
  (setq transient-mark-mode xxx-original-transient-mark-mode))

(defun xxx-quit ()
  "Quit `xxx'."
  (interactive)
  (xxx-exit)
  (keyboard-quit))

(defun xxx-restore-and-quit ()
  "Restore point and mark, and quit."
  (interactive)
  (goto-char xxx-original-point)
  (set-mark xxx-original-mark)
  (xxx-quit))

(defun xxx-search-next-mark (pos ring)
  (let (new-mark)
    (dolist (mark ring)
      (when (and (> (marker-position mark) pos)
		 (or (null new-mark)
		     (< (marker-position mark) (marker-position new-mark))))
	(setq new-mark mark)))
    new-mark))
      
(defun xxx-search-previous-mark (pos ring)
  (let (new-mark)
    (dolist (mark ring)
      (when (and (< (marker-position mark) pos)
		 (or (null new-mark)
		     (> (marker-position mark) (marker-position new-mark))))
	(setq new-mark mark)))
    new-mark))

(defun xxx-delete-duplicate-mark-ring (ring)
  (let (new-ring)
    (dolist (mark ring)
      (unless (member mark new-ring)
	(push mark new-ring)))
    new-ring))

      
(provide 'xxx)
;;; xxx.el ends here