;; 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 とは相性が悪い.

;; ============================================================
;; Mell (2002-05-18)
;; ============================================================

(or (boundp 'running-xemacs)
    (setq running-xemacs nil))

(defun mell-set-minor-mode (name modeline &optional key-map)
  (make-variable-buffer-local name)
  (setq minor-mode-alist
	(mell-alist-add minor-mode-alist (list name modeline)))
  (and key-map
       (setq minor-mode-map-alist
	     (mell-alist-add minor-mode-map-alist (cons name key-map)))
       )
  )

(or (fboundp 'add-local-hook)
    (defun add-local-hook (hook function &optional append)
      (make-local-hook hook)
      (add-hook hook function append t))
    )

(or (fboundp 'remove-local-hook)
    (defun remove-local-hook (hook function)
      (if (local-variable-p hook (current-buffer))
	  (remove-hook hook function t)))
    )

(defun mell-alist-add! (alist new-cons)
  (if (null alist)
      (error "mell-alist-add! can not deal nil as an alist.")
    (let ((current-cons (assoc (car new-cons) alist)))
      (if current-cons
	  (setcdr current-cons (cdr new-cons))
	(if (car alist)
	    (nconc alist (list new-cons))
	  (setcar alist new-cons))
	)
      alist)))
  
(defun mell-alist-add (alist new-cons)
  (if (null alist)
      (list new-cons)
    (let ((return-alist (copy-alist alist)))
      (mell-alist-add! return-alist new-cons)
      return-alist)))

(defun mell-transient-region-stay ()
  (and running-xemacs
       (setq zmacs-region-stays t))
  )
;;;; ------------------------------------------------------------
(defvar physical-line-mode-map (make-sparse-keymap))
(substitute-key-definition 'beginning-of-line 'physical-line-beginning-of-line
			   physical-line-mode-map global-map)
(substitute-key-definition 'end-of-line 'physical-line-end-of-line
			   physical-line-mode-map global-map)

(defvar physical-line-mode nil 
  "*Non-nil means move cursor to same column of frame line.")
(mell-set-minor-mode 'physical-line-mode " PL" physical-line-mode-map)

;(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)))
      (cond 
       ((> moved arg)
	(signal 'beginning-of-buffer nil))
       ((< moved arg)
	(goto-char (point-max))
	(signal 'end-of-buffer nil))
       ))
    (physical-line-move-to-column temporary-goal-column)
    ))

(defun physical-line-end-of-line (&optional count)
  (interactive "P")
  (if (and (eq last-command 'physical-line-end-of-line)
	   (null count))
      (end-of-line)
    (if (= (physical-line-the-vertical-motion (prefix-numeric-value count))
	   (prefix-numeric-value count))
	(backward-char 1))
    )
  (mell-transient-region-stay)
  )

(defun physical-line-beginning-of-line (&optional count)
  (interactive "P")
  (if (and (eq last-command 'physical-line-beginning-of-line)
	   (null count))
      (beginning-of-line)
    (physical-line-the-vertical-motion (1- (prefix-numeric-value count)))
    )
  (mell-transient-region-stay)
  )

;;;; (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)
	(1+ (physical-line-the-vertical-motion-plus (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.el,v 1.2 2002/08/26 20:35:08 komatsu Exp $

(provide 'physical-line)