;;; fusion.el --- CodeWright Fusion-style motion and text selection

;; Copyright (C) 1997 Kirill M. Katsnelson

;; Author: Kirill M. Katsnelson <kkm@kis.ru>
;; Date written: 1997
;; Keywords: keyboard selection region
;; Version: 1.2

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

;; Fusion provides emulation of cursor motion and shift-mark selection 
;; compatible with CodeWright Fusion. 
;;
;; CodeWright is a text editor with concepts close to emacs and
;; XEmacs, sold by Premia Corp. It has similar barenaked shell stuffed 
;; with editing functionality using macro language, but unlike emacsen
;; it uses a set of C macros, so its macros are externally compiled.
;;
;; 'Fusion' is a mode of CodeWright which resembles closely the
;; behavior of Microsoft Developer Studio embedded editor. The correct 
;; name for this package would be msvc-motion then; but, author's
;; opinion is that 'fusion' sounds better!
;;
;; Usage:
;; ------
;; Put the one of the following lines into your .emacs file:
;;    (fusion-set-mode t)   ;; Load fusion and turn it on
;; or
;;    (require 'fusion)     ;; Load fusion and turn it off
;;
;; If you want that fusion mode does not appear neither on the
;; modeline nor in the minor mode menu, also add
;;    (put 'fusion-mode :included nil)
;;
;; (this only makes sense if you turn on the mode programmatically:
;;  in this case, there in no way to turn it on from the UI)
;;
;; [As of 21.0 beta 31, the mode indicator is not hidden on the
;;  modeline. This probably will be fixed]

;;; ChangeLog

;; First written long ago
;; November 1997	: v1.2: converted into a minor mode.
;; March 1997		: First public release.

;;; Code:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Set-up
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar fusion-mode nil
  "Non-nil when fusion mode is enabled. Do not set this.
You should call `fusion-set-mode' or `fusion-mode' instead.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Caret motion functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun fusion-up (&optional ARG)
  "Move up a line"
  (interactive "_p")
  ;; Awful unbelievable kludge.
  (setq this-command 'previous-line)
  (condition-case nil
      (previous-line ARG)
    (beginning-of-buffer nil)))

(defun fusion-down (&optional ARG)
  "Move down a line"
  (interactive "_p")
  ;; Utter topmost kludge.
  (setq this-command 'next-line)
  (condition-case nil
      (next-line ARG)
    (end-of-buffer nil)))

(defun fusion-left (&optional ARG)
  "Move left a character. Do not signal if sob is reached."
  (interactive "_p")
  (condition-case nil
      (backward-char ARG)
    (beginning-of-buffer nil)))

(defun fusion-right (&optional ARG)
  "Move right a character. Do not signal if eob is reached."
  (interactive "_p")
  (condition-case nil
      (forward-char ARG)
    (end-of-buffer nil)))

(defun fusion-home ()
  "Go to the first non-blank in the line or to the line start.
Moves to the line beginning if positioned on or left to the first
non-blank character on the line. Moves to the first non-blank
character if positioned right to such character or at the line
beginning."
  (interactive "_")
  (if (zerop (current-column))
      (back-to-indentation)
    (let ((oldpos (point)))
      (back-to-indentation)
      (if (<= oldpos (point))
	  (beginning-of-line)))))

(defun fusion-end ()
  "Go to the end of the current line."
  (interactive "_")
  (end-of-line))

;This function returns amount of lines to scroll, based on current window size
(defun fusion-scroll-lines ()
  "This is an internal function of the fusion package"
  (max 1 (- (window-displayed-height) next-screen-context-lines)))

(defun fusion-pageup (&optional ARG)
  "Move ARG (or 1) pages up. Stop exactly at the start of buffer."
  (interactive "_p")
  (condition-case nil
      (scroll-down
       (if (and ARG (> ARG 1))
	   ARG
	(fusion-scroll-lines)))
    (beginning-of-buffer (fusion-bob))))

(defun fusion-pagedown (&optional ARG)
  "Move ARG (or 1) pages down. Stop exactly at end of buffer."
  (interactive "_p")
  (condition-case nil
      (scroll-down
       (- (if (and ARG (> ARG 1))
	      ARG
	    (fusion-scroll-lines))))
    (end-of-buffer (fusion-sol-eob))))

(defun fusion-bob ()
  "Go to the beginning of buffer."
  (interactive "_")
  (goto-char 0))
  
(defun fusion-sol-eob ()
  "Go to the beginning of the last line of buffer."
  (interactive "_")
  (goto-char (point-max))
  (beginning-of-line))
  
(defun fusion-eob ()
  "Go to the end of buffer."
  (interactive "_")
  (goto-char (point-max)))
  
(defun fusion-wordleft (&optional ARG)
  "Go to the beginning of the previous word"
  (interactive "_p")
  (condition-case nil
      (forward-word (- (or ARG 1)))
    (beginning-of-buffer nil)))

(defun fusion-wordright (&optional ARG)
  "Go to the end of the next word"
  (interactive "_p")
  (condition-case nil
      (forward-word (or ARG 1))
    (end-of-buffer nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Shift-arrows region mark functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;
;; This var stores point recorded by pre-command hook.
;;
(defvar fusion-precommand-point 0
  "This is an internal variable of the fusion package")

;;
;; This variable is set to t after zmacs-regions warning has
;; been reported to user
;;
(defvar fusion-zmacs-regions-warned-p nil
  "This is an internal variable of the fusion package")

;;
;; This just stores before-command position,
;; to which we can possibly move mark in our
;; post-command hook
;;
(defun fusion-precommand ()
  "This is an internal function of the fusion package"
  (setq fusion-precommand-point (point)))

;;
;; The algorithm is as follows:
;; If position has changed AND the key is pressed,
;; AND this was a motion key, THEN:
;;   IF region is currently active AND shift key
;;      was up, then deactivate region;
;;   IF region is inactive, AND shift key is down,
;;      then set mark to the pre-command position
;;      and activate the region.
;; 
(defun fusion-postcommand ()
  "This is an internal function of the fusion package"
  (if zmacs-regions
      (when (and
	     (key-press-event-p last-input-event)
	     (memq (event-key last-input-event) '(left right up down home end prior next)))
	; Trigger to issue a warning again if zmacs-regions will be re-disabled
	(setq fusion-zmacs-regions-warned-p nil)
	(let ((shift-down (memq 'shift (event-modifiers last-input-event))))
	  (when (and zmacs-region-active-p (not shift-down))
	    (zmacs-deactivate-region)
	    (setq zmacs-region-stays nil))
	  (when (and (not zmacs-region-active-p) shift-down)
	    (set-mark fusion-precommand-point)
	    (zmacs-activate-region))))
    (unless fusion-zmacs-regions-warned-p
      (setq fusion-zmacs-regions-warned-p t)
      (warn "Fusion style selection does not work unless zmacs-regions are enabled!"))))

;;
;; This function disables fusion keys in a minibuffer.
;; Hooks and thus shift-mark still works though.
;;
(defun fusion-minibuffer-setup ()
  "This is an internal function of the fusion package"
  (set (make-local-variable 'fusion-mode) nil))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Toggle function
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;###autoload
(defun fusion-mode ()
  "Toggle fusion mode on and off.
See also `fusion-set-mode'"
  (interactive)
  (let ((fn (if fusion-mode 'remove-hook 'add-hook)))
    (funcall fn 'pre-command-hook 'fusion-precommand)
    (funcall fn 'post-command-hook 'fusion-postcommand))
  (setq fusion-mode (not fusion-mode))
  (redraw-modeline t)
  fusion-mode)

;;;###autoload
(defun fusion-set-mode (&optional on)
  "Turn fusion mode off when ON is nil, on otherwise
See also `fusion-mode'"
  (when (or (and on (not fusion-mode))
	    (and (not on) fusion-mode))
    (fusion-mode)))

; Guard against double init
(unless (featurep 'fusion)
  (add-minor-mode 'fusion-mode " Fusn"
		  (let ((map (make-keymap)))
		    (define-key map 'up 'fusion-up)
		    (define-key map 'down 'fusion-down)
		    (define-key map 'left 'fusion-left)
		    (define-key map 'right 'fusion-right)
		    (define-key map 'prior 'fusion-pageup)
		    (define-key map 'next 'fusion-pagedown)
		    (define-key map 'home 'fusion-home)
		    (define-key map 'end 'fusion-end)
		    (define-key map '(control up) 'fusion-up)
		    (define-key map '(control down) 'fusion-down)
		    (define-key map '(control left) 'fusion-wordleft)
		    (define-key map '(control right) 'fusion-wordright)
		    (define-key map '(control prior) 'fusion-bob)
		    (define-key map '(control next) 'fusion-sol-eob)
		    (define-key map '(control home) 'fusion-bob)
		    (define-key map '(control end) 'fusion-eob)
		    map))
  (add-hook 'minibuffer-setup-hook 'fusion-minibuffer-setup))

(provide 'fusion)

;;; fusion.el ends here