;; physical-line.el            by Hiroyuki Komatsu <komatsu@taiyaki.org>
;;
;; Change cursor moving style from Logical Line to Physical Line.
;; This program is GPLed.
;;
;; = How To Use =
;; M-x load-file [physical-line.el]
;; M-x physical-line-mode
;;
; TODO 
;  物理行表示の復活.
; 
; BUGS
;  dired-mode とは相性が悪い.

(defvar physical-line-mode nil 
  "*Non-nil means move cursor to same column of frame line.")
(make-variable-buffer-local 'physical-line-mode)
(if (not (assq 'physical-line-mode minor-mode-alist))
    (setq minor-mode-alist
	  (cons '(physical-line-mode " PLine") minor-mode-alist)))

(defvar physical-line-mode-exception '(dired-mode)
  "physical-line-move-without-exception except modes of this list.")

(defun physical-line-mode (&optional arg)
  "Toggle Physical Line mode.
With ARG, turn Physical Line mode on iff ARG is positive.
When Physical Line mode is enabled, cursor moving style is changed
from Logical to Physical."
  (interactive "P")
  (setq physical-line-mode (if (null arg)
                              (not physical-line-mode)
                            (> (prefix-numeric-value arg) 0)))
  (if physical-line-mode
      (ad-enable-advice 'line-move 'around 'physical-line-move)
    (ad-disable-advice 'line-move 'around 'physical-line-move))
  (ad-activate 'line-move))

(defun physical-line-mode-on ()
  "Turn on Physical Line mode."
  (interactive)
  (physical-line-mode t))

(defun physical-line-mode-off ()
  "Turn off Physical Line mode."
  (interactive)
  (physical-line-mode -1))

(defun physical-line-mode-without-exception ()
  "Turn on Physical Line mode without modes which are members of physical-line-move-exceptionthe."
  (physical-line-mode 
   (if (memq major-mode physical-line-mode-exception) -1 t)
   ))

;; (defun physical-line-same-line-p (point1 point2)
;;   "Return t, if point1 and point2 are on same line."
;;   (save-excursion
;;     (eq (progn (goto-char point1) (beginning-of-line) (point))
;; 	(progn (goto-char point2) (beginning-of-line) (point))
;; 	)))

(defun physical-current-column ()
  (let ((cur (current-column))
	(bol (progn (physical-line-the-vertical-motion 0) 
		    (current-column))))
    (move-to-column cur)
    (- cur bol)))

(defadvice line-move (around physical-line-move disable)
  "Move cursor to same column of frame line down ARG lines."
  (if (not physical-line-mode)
      ;; physical-line-mode 以外のときは何もしない
      ad-do-it
    (and (not (or (eq last-command 'next-line)
		  (eq last-command 'previous-line)))
	 ;; temporary-goal-column は pline-mode 以前の line-move と共用
	 (setq temporary-goal-column (physical-current-column)))
    (let* ((arg (ad-get-arg 0))
	   (moved (physical-line-the-vertical-motion arg)))
      (and (> moved arg) (signal 'beginning-of-buffer nil))
      (and (< moved arg) (signal 'end-of-buffer nil)))
    (physical-line-move-to-column temporary-goal-column)
    ))

;;;; (Emacs21 の move-to-column は WIDE 文字に未対応)
(defun physical-line-move-to-column (arg)
  (and (> arg 0)
       (move-to-column (+ (current-column) arg -1))
       (not (eolp))
       (let ((column (physical-current-column)))
	 (while (not (or (> column arg)
			 (and (= column 0) (> arg 1))))
	   (forward-char 1)
	   (setq column (physical-current-column))
	   )
	 (forward-char -1))
       ))

;;;; The vertical motion (Emacs21 の vertical-motion は WIDE 文字に未対応)
(if (and (boundp 'running-xemacs) running-xemacs)
    (defalias 'physical-line-the-vertical-motion 'vertical-motion)
(defun physical-line-the-vertical-motion (arg)
  (cond ((> arg 0)
	 (physical-line-the-vertical-motion-plus arg))
	((= arg 0)
	 (physical-line-the-vertical-motion-zero))
	(t ; (< arg 0)
	 (physical-line-the-vertical-motion-minus arg))
	))
)

(defun physical-line-the-vertical-motion-plus (arg)
  (physical-line-the-vertical-motion-zero)
  (if (eolp)
      (progn
	(forward-char 1)
	arg)
    (forward-char 1)
    (prog1 (vertical-motion arg)
      (physical-line-the-vertical-motion-zero))))
  
(defun physical-line-the-vertical-motion-zero ()
  (cond ((eolp)
	 (vertical-motion 0))
	((= (point)
	    (progn (save-excursion
		     (forward-char 1) (vertical-motion 0) (point))))
	 0)
	(t
	 (vertical-motion 0))
	))

(defun physical-line-the-vertical-motion-minus (arg)
  (let ((count arg))
    (while (and (< count 0) (not (bobp)))
      (physical-line-the-vertical-motion-zero)
      (forward-char -1)
      (physical-line-the-vertical-motion-zero)
      (setq count (1+ count)))
    (- arg count)
    ))


; 物理行表示は別のマイナーモードにする.
;(defun physical-line-mode (&optional arg refresh)
;  "Toggle Physical Line mode.
;With ARG, turn Physical Line mode on iff ARG is positive.
;When Physical Line mode is enabled, cursor moving style is changed
;from Logical to Physical.
;And with REFRESH, reset lisp function line-move for Logical Line
;which is normal cursor moving style."
;  (interactive "P")
;  (setq physical-line-mode (if (null arg)
;                             (not physical-line-mode)
;                           (> (prefix-numeric-value arg) 0)))
;  (or (boundp 'original-mode-line-format)
;      (progn
;       (make-local-variable 'original-mode-line-format)
;       (setq original-mode-line-format mode-line-format)
;       (setq physical-mode-line-format 
;             (physical-line-modeline mode-line-format))))
;  (make-local-hook 'post-command-hook)
;  (if physical-line-mode
;      (progn
;       (ad-enable-advice 'line-move 'around 'physical-line-move)
;       (setq mode-line-format physical-mode-line-format)
;       (add-hook 'post-command-hook 'physical-line-set-position))
;    (ad-disable-advice 'line-move 'around 'physical-line-move)
;    (setq mode-line-format original-mode-line-format)
;    (remove-hook 'post-command-hook 'physical-line-set-position))
;  (ad-activate 'line-move))

;物理行表示用なので, 現在未使用.
;(defun physical-line-modeline (&optional ml)
;  "Make modeline for display Physical Line and Column."
;  (make-local-variable 'physical-line)
;  (make-local-variable 'physical-column)
;  (physical-line-set-position)
;  (or ml (setq ml mode-line-format))
;  (mapcar 
;   (function (lambda (arg)
;	       (cond ((and (listp arg) (eq (car arg) 'line-number-mode))
;		      '(line-number-mode ("PL" physical-line "--")))
;		     ((and (listp arg) (eq (car arg) 'column-number-mode))
;		      '(column-number-mode ("PC" physical-column "--")))
;		     (t arg))))
;   ml))

;物理行表示用なので, 現在未使用.
;(defun physical-line-set-position ()
;  "Set strings of Physical Column and Line for modeline."
;  (setq physical-column (number-to-string (physical-current-column)))
;  (setq physical-line 
;	(let ((pos (point))
;	      (line (vertical-motion -10000)))
;	  (goto-char pos)
;	  (if (= line -10000)
;	      "****"
;	    (number-to-string (- 1 line))))))

; $Id: physical-line_2002-05-08.el,v 1.1.1.1 2002/08/25 14:24:47 komatsu Exp $