;;; pc-select.el --- PC shift selection minor mode for XEmacs

;; Copyright (C) 1997 Gary D. Foster

;; Author: Gary D. Foster <Gary.Foster@sun.com>
;; Created: 23 Dec 1997
;; Version: 1.5
;; Keywords: hardware, mouse

;; This file is part of XEmacs.

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

;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not synched.

;;; Commentary:

;; This is a complete rewrite of the pc-select package in FSF Emacs
;; originally written by Michael Staats <michael@thp.Uni-Duisburg.DE>.
;; The FSF version contained the desired functionality, but at the expense
;; of being a very lousy citizen of the XEmacs environment.

;; If you need support for this package or wish to request a feature or
;; report a bug, please contact <gary.foster@sun.com> and do not contact
;; the original author.  They are not responsible for this, I am.

;; This package is a minor mode and set of bindings to emulate the shift
;; selection feature of various PC environments.  When the user presses
;; and holds the shift key while pressing an arrow key (up, down, left, or
;; right) or any permuation of commands involving S-<arrow> it is desired
;; that mark be set during the operation.  Thus, to mark an entire line
;; you could press the S-down key chord, which would set the mark at the
;; place where the movement began, and then move down one line.  Similar
;; functionality exists for the rest of the movement combos involving the
;; arrow keys.

;; Note: This package enables (and is dependent upon) pending-del mode
;; when the pc-select minor mode is enabled.

;;; $Log: pc-select.el,v $
;;; Revision 1.7  2002/01/12 05:17:05  youngs
;;; 2002-01-10  John Paul Wallington  <jpw@shootybangbang.com>
;;;
;;; 	* pending-del.el (pending-delete-modeline-string): fix custom type.
;;; 	* pc-select.el (pc-select-modeline-string): fix custom type.
;;;
;;; Revision 1.6  2001/05/09 23:59:24  youngs
;;; Patch from Sean MacLennan  <seanm@storm.ca>
;;;
;;; Revision 1.5  2000/10/06 09:02:23  youngs
;;; Martin's Monster Mega typo patch
;;;
;;; Revision 1.4  1999/05/13 16:46:02  steveb
;;; MS Windows fixes
;;;
;;; Revision 1.5  1998/02/20 06:25:28  gfoster
;;; Fixed a really esoteric bug where point position wasn't being
;;; preserved exactly when traversing ragged lines.
;;;
;;; Kudos to Erik Sundermann <erik@petaxp.rug.ac.be> for
;;; spotting this.
;;;
;;; Also, switched to using '(forward-char (- arg))' style
;;; routines which (according to Hrvoje) should be a
;;; skosh faster.
;;;

;;; Revision 1.4  1997/12/29 21:08:06  gfoster
;;; Added a bunch of keybindings (prior/next/home/end and various
;;; permutations thereof).
;;; Automatically enable pending-del mode when this minor mode is enabled.
;;; Added doc strings for all the functions.

;; Revision 1.3 1997/12/26 20:04:26   gfoster
;; Tweaked package profile and comment headers to standardize with XEmacs
;;
;; Revision 1.2  1997/12/24 02:34:12  gfoster
;; Added standard XEmacs comment headers
;;
;; Revision 1.1  1997/12/24 02:29:49  gfoster
;; Initial revision
;;

;; Code:

;; local variables

(defgroup pc-select nil
  "PC Selection mode customizable settings."
  :group 'editing-options)

(defvar pc-select-map (let ((map (make-sparse-keymap)))
			(set-keymap-parent map (current-global-map))
			map)
  "Local keymap for pc-select mode.")

(defcustom pc-select-modeline-string " PC"
  "*String to display in the modeline when pc-select mode is active.
Set this to nil if you don't want a modeline indicator."
  :type '(choice string
		 (const :tag "none" nil))
  :group 'pc-select)

(defvar pc-select-original-keymap (current-global-map)
  "The original keymap before pc-select mode remaps anything.
This keymap is restored when the mode is disabled.")

(defvar pc-select-enabled nil
  "Track status of pc-select mode.
A value of nil means pc-select mode is not enabled.  A value of t
indicates it is enabled.")

(defvar pc-select-keep-regions nil
  "Non-nil means that the zmacs region will be preserved on motion commands.")

(defconst pc-select-version "1.4"
  "The version of the pc-select package.")

;; keymap defines

;; Normal movement keys should deselect the region (I think this is stupid,
;; but people demanded it)

(define-key pc-select-map [(right)]		'pc-select-move-char-right)
(define-key pc-select-map [(left)]		'pc-select-move-char-left)
(define-key pc-select-map [(control right)]     'pc-select-move-word-right)
(define-key pc-select-map [(control left)]	'pc-select-move-word-left)
(define-key pc-select-map [(up)]		'pc-select-move-line-up)
(define-key pc-select-map [(down)]		'pc-select-move-line-down)
(define-key pc-select-map [(home)]		'pc-select-move-bol)
(define-key pc-select-map [(end)]		'pc-select-move-eol)
(define-key pc-select-map [(control home)]	'pc-select-move-bob)
(define-key pc-select-map [(control end)]	'pc-select-move-eob)
(define-key pc-select-map [(prior)]		'pc-select-move-page-up)
(define-key pc-select-map [(next)]		'pc-select-move-page-down)

;; Shift + movement by character or line

(define-key pc-select-map [(shift right)]	'pc-select-mark-char-right)
(define-key pc-select-map [(shift left)]  	'pc-select-mark-char-left)

;; C-S-arrow marks by word

(define-key pc-select-map [(control shift right)] 'pc-select-mark-word-right)
(define-key pc-select-map [(control shift left)]  'pc-select-mark-word-left)

;; line marking

(define-key pc-select-map [(shift up)]		'pc-select-mark-line-up)
(define-key pc-select-map [(shift down)]	'pc-select-mark-line-down)
(define-key pc-select-map [(shift home)]	'pc-select-mark-to-bol)
(define-key pc-select-map [(shift end)]		'pc-select-mark-to-eol)

;; page marking

(define-key pc-select-map [(shift prior)]	'pc-select-mark-page-up)
(define-key pc-select-map [(shift next)]	'pc-select-mark-page-down)

;; buffer marking

(define-key pc-select-map [(control shift home)] 'pc-select-mark-to-bob)
(define-key pc-select-map [(control shift end)] 'pc-select-mark-to-eob)

;; cut and paste

(define-key pc-select-map [(shift delete)]	'kill-primary-selection)
(define-key pc-select-map [(shift insert)]	'yank-clipboard-selection)
(define-key pc-select-map [(control insert)]	'copy-primary-selection)

;; this defun makes sure mark is set.

(defun pc-select-ensure-mark ()
  "Ensures mark is set at point."
  (if zmacs-region-active-p
      (setq zmacs-region-stays t)
    (set-mark-command nil)))

;; normal (unshifted) movement commands disable the region before moving

(defun pc-select-move-char-right (&optional arg)
  "Move point right ARG characters, deselecting any marked region.
Moves left if ARG is negative."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'forward-char)
  (forward-char arg))

(defun pc-select-move-char-left (&optional arg)
  "Move point left ARG characters, deselecting any marked region.
Moves right if ARG negative."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'backward-char)
  (forward-char (- arg)))

(defun pc-select-move-word-right (&optional arg)
  "Move point right ARG words, deselecting any marked region.
Moves left if ARG is negative."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'forward-word)
  (forward-word arg))

(defun pc-select-move-word-left (&optional arg)
  "Move point left ARG words, deselecting any marked region.
Moves right if ARG is negative."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'backward-word)
  (forward-word (- arg)))

(defun pc-select-move-line-up (&optional arg)
  "Move point up ARG lines, deselecting any marked region.
Moves down if ARG is negative."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'previous-line)
  (call-interactively 'previous-line arg))

(defun pc-select-move-line-down (&optional arg)
  "Move point down ARG lines, deselecting any marked region.
Moves up if ARG is negative."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'next-line)
  (call-interactively 'next-line arg))

(defun pc-select-move-bol (&optional arg)
  "Move point to the beginning of the line, deselecting any marked region.
With argument ARG not nil or 1, move forward ARG - 1 lines first.
If scan reaches end of buffer, stop there without error."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'beginning-of-line)
  (beginning-of-line arg))

(defun pc-select-move-eol (&optional arg)
  "Move point to the end of the line, deselecting any marked region.
With argument ARG not nil or 1, move forward ARG -1 lines first.
If scan reaches end of buffer, stop there without error."
  (interactive "p")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'end-of-line)
  (end-of-line arg))

(defun pc-select-move-page-up (&optional arg)
  "Scroll text of current window down ARG lines, deselecting any marked region.
Scrolls near full screen if no ARG, scrolls upward if ARG is negative.

See `scroll-down' for further info."
  (interactive "P")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'scroll-down)
  (call-interactively 'scroll-down-command arg))

(defun pc-select-move-page-down (&optional arg)
  "Scroll text of current window up ARG lines, deselecting any marked region.
Scrolls near full screen if no ARG, scrolls downward if ARG is negative.

See `scroll-up' for further info."
  (interactive "P")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'scroll-up)
  (call-interactively 'scroll-up-command arg))

(defun pc-select-move-bob (&optional arg)
  "Move point to the beginning of buffer, deselecting any active region.
With arg N, put point N/10 of the way from the beginning.

If the buffer is narrowed, this command uses the beginning and size
of the accessible part of the buffer."
  (interactive "P")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'beginning-of-buffer)
  (beginning-of-buffer))

(defun pc-select-move-eob (&optional arg)
"Move point to the end of buffer, deselecting any active region.
With arg N, put point N/10 of the way from the end.

If the buffer is narrowed, this command uses the beginning and size
of the accessible part of the buffer."
  (interactive "P")
  (setq zmacs-region-stays pc-select-keep-regions)
  (setq this-command 'end-of-buffer)
  (end-of-buffer))

;; marking movement functions

(defun pc-select-mark-char-right (&optional arg)
  "Move point right and mark ARG characters.
Moves and selects left if ARG is negative."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'forward-char)
  (forward-char arg))

(defun pc-select-mark-char-left (&optional arg)
  "Move point left and mark ARG characters.
Moves and selects right if ARG is negative."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'backward-char)
  (forward-char (- arg)))

(defun pc-select-mark-word-right (&optional arg)
  "Move point right and mark ARG words.
Moves and selects left if ARG is negative."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'forward-word)
  (forward-word arg))

(defun pc-select-mark-word-left (&optional arg)
  "Move point left and mark ARG words.
Moves and selects right if ARG is negative."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'backward-word)
  (forward-word (- arg)))

(defun pc-select-mark-line-up (&optional arg)
  "Move point up and select ARG lines.
Moves down if ARG is negative."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'previous-line)
  (call-interactively 'previous-line arg))

(defun pc-select-mark-line-down (&optional arg)
  "Move point down and select ARG lines.
Moves up if ARG is negative."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'next-line)
  (call-interactively 'next-line arg))

(defun pc-select-mark-to-bol (&optional arg)
  "Move point and mark to the beginning of the line.
With argument ARG not nil or 1, move forward ARG - 1 lines first.
If scan reaches end of buffer, stop there without error."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'beginning-of-line)
  (beginning-of-line arg))

(defun pc-select-mark-to-eol (&optional arg)
  "Move point and mark to the end of the line.
With argument ARG not nil or 1, move forward ARG -1 lines first.
If scan reaches end of buffer, stop there without error."
  (interactive "p")
  (pc-select-ensure-mark)
  (setq this-command 'end-of-line)
  (end-of-line arg))

(defun pc-select-mark-page-up (&optional arg)
  "Scroll text of current window down and mark ARG lines.
Scrolls near full screen if no ARG, scrolls upward if ARG is negative.

See `scroll-down' for further info."
  (interactive "P")
  (pc-select-ensure-mark)
  (setq this-command 'scroll-down)
  (call-interactively 'scroll-down arg))

(defun pc-select-mark-page-down (&optional arg)
  "Scroll text of current window up and mark ARG lines.
Scrolls near full screen if no ARG, scrolls downward if ARG is negative.

See `scroll-up' for further info."
  (interactive "P")
  (pc-select-ensure-mark)
  (setq this-command 'scroll-up)
  (call-interactively 'scroll-up arg))

(defun pc-select-mark-to-bob (&optional arg)
    "Move point and mark to the beginning of buffer.
With arg N, put point N/10 of the way from the beginning.

If the buffer is narrowed, this command uses the beginning and size
of the accessible part of the buffer."
  (interactive "P")
  (pc-select-ensure-mark)
  (setq this-command 'beginning-of-buffer)
  (beginning-of-buffer arg))

(defun pc-select-mark-to-eob (&optional arg)
  "Move point and mark to the end of buffer."
  (interactive "P")
  (pc-select-ensure-mark)
  (setq this-command 'end-of-buffer)
  (end-of-buffer arg))

;; enable the mode

(defun pc-select-mode (&optional arg)
  "Toggle pc select minor mode.
With ARG, turn mode on if ARG is positive, off otherwise."
  (interactive "P")
  (setq pc-select-enabled (if (null arg)
			      (not pc-select-enabled)
			    (> (prefix-numeric-value arg) 0)))
  (cond
   ((eq pc-select-enabled 't)
    (use-global-map pc-select-map)
    (require 'pending-del)
    (turn-on-pending-delete))
   ((eq pc-select-enabled 'nil)
    (use-global-map pc-select-original-keymap))))

(if (fboundp 'add-minor-mode)
    (add-minor-mode 'pc-select-enabled 'pc-select-modeline-string
                    nil nil 'pc-select-mode)
  (or (assq 'pc-select-enabled minor-mode-alist)
      (setq minor-mode-alist
            (cons '(pc-select-enabled pc-select-modeline-string) minor-mode-alist))))

(defun pc-select-toggle-regions (&optional force)
  "Toggle region retention behavior."
  (interactive "_P")
  (if force
      (setq pc-select-keep-regions t)
    (setq pc-select-keep-regions (not pc-select-keep-regions))))

(provide 'pc-select)

;;; pc-select.el ends here
