;;; -*- Mode: Lisp; Package: EDITOR -*-
;;;
;;; This file is not part of xyzzy.
;;;
; $Id: text-fill.l,v 1.16 2001-12-19 14:27:17+09 hattori Exp hattori $
;
; text-fill-minor-mode for xyzzy
;
; by HATTORI Masashi <gyo@he.mirai.ne.jp>

(provide "text-fill")

(require "fill")

(in-package "editor")

(export '(text-fill-mode
	  *text-fill-tab-columns*
	  *text-fill-prefix-chars*
	  *text-fill-mode-map*))

(defvar *text-fill-start-regexp* "^\t+")
(defvar *text-fill-prefix-chars*
  '("○" "△" "◇" "□" "☆" "◎" "●" "▲" "◆" "■" "★" "・" "≫" "∴" "※" "＊" "〆" "♪" "＞"))
(defvar *text-fill-prefix-regexp* nil)
(defvar *text-fill-number-regexp* "\\([0-9]+\\)[.:] *")
(defvar *text-fill-padding-char* "  ")
(defvar *text-fill-continue-regexp* (concat "^\t*" *text-fill-padding-char*))

(defvar *text-fill-indent-columns* 1)
(defvar *text-fill-indent-tabs-mode* t)
(defvar *text-fill-tab-columns* *tab-columns*)

(defvar-local *text-fill-mode* nil)
(defvar *text-fill-mode-map* nil)

(unless *text-fill-mode-map*
  (setq *text-fill-mode-map* (make-sparse-keymap))
  (define-key *text-fill-mode-map* #\RET 'text-fill-newline-and-indent)
  (define-key *text-fill-mode-map* #\TAB 'text-fill-indent-plus)
  (define-key *text-fill-mode-map* #\S-F23 'text-fill-indent-minus)
  (define-key *text-fill-mode-map* #\M-Right 'text-fill-indent-plus)
  (define-key *text-fill-mode-map* #\M-Left 'text-fill-indent-minus)
  (define-key *text-fill-mode-map* #\C-h 'text-fill-back-space)
  (define-key *text-fill-mode-map* #\M-Insert 'text-fill-insert-current-prefix-char)
  (define-key *text-fill-mode-map* '(#\C-c #\Insert) 'text-fill-prefix-char-change)
  (define-key *text-fill-mode-map* '(#\C-c #\0) #'(lambda () (interactive) (text-fill-prefix-char-change 0)))
  (define-key *text-fill-mode-map* '(#\C-c #\1) #'(lambda () (interactive) (text-fill-prefix-char-change 1)))
  (define-key *text-fill-mode-map* '(#\C-c #\2) #'(lambda () (interactive) (text-fill-prefix-char-change 2)))
  (define-key *text-fill-mode-map* '(#\C-c #\3) #'(lambda () (interactive) (text-fill-prefix-char-change 3)))
  (define-key *text-fill-mode-map* '(#\C-c #\4) #'(lambda () (interactive) (text-fill-prefix-char-change 4)))
  (define-key *text-fill-mode-map* '(#\C-c #\5) #'(lambda () (interactive) (text-fill-prefix-char-change 5)))
  (define-key *text-fill-mode-map* '(#\C-c #\6) #'(lambda () (interactive) (text-fill-prefix-char-change 6)))
  (define-key *text-fill-mode-map* '(#\C-c #\7) #'(lambda () (interactive) (text-fill-prefix-char-change 7)))
  (define-key *text-fill-mode-map* '(#\C-c #\8) #'(lambda () (interactive) (text-fill-prefix-char-change 8)))
  (define-key *text-fill-mode-map* '(#\C-c #\9) #'(lambda () (interactive) (text-fill-prefix-char-change 9)))
  (set-extended-key-translate-table exkey-S-tab #\S-F23)
  )

(defun text-fill-back-space ()
  (interactive)
  (if (and (not (bolp))
	   (or (looking-at *text-fill-prefix-regexp*)
	       (looking-at *text-fill-number-regexp*)))
      (text-fill-indent-minus)
    (delete-backward-char-or-selection)))

(defun text-fill-previous-line ()
  "前の段落の先頭らしきとこまで戻る"
  (while (forward-line -1)
    (unless (text-fill-skip-line-p)
      (return-from text-fill-previous-line t))))

(defun text-fill-current-indent ()
  (let ((str ""))
    (save-excursion
      (goto-bol)
      (when (looking-at *text-fill-start-regexp*)
	(setq str (match-string 0))))
    str))

(defun text-fill-back-to-start (indent)
  "段落の先頭らしきとこまで戻る"
  (let ((indent-str (text-fill-padding-tab indent)))
    (while (forward-line -1)
      (let ((str (text-fill-current-indent)))
	(unless (equal indent-str str)
	  (forward-line 1)
	  (return-from text-fill-back-to-start t))
	(multiple-value-bind (indent prefix number)
	    (text-fill-count-indent)
	  (when (or prefix number)
	    (return-from text-fill-back-to-start t)))))))

(defun text-fill-skip-line-p ()
  "段落の先頭じゃない？"
  (save-excursion
    (goto-bol)
    (or (looking-at "^ *$")
	(looking-at *text-fill-continue-regexp*)
	(looking-at *text-fill-number-regexp*))))

(defun text-fill-indent (&optional insert-prefix)
  "てきとーにインデントする"
  (interactive)
  (let (indent prefix number)
    (save-excursion
      (when (text-fill-previous-line)
	(multiple-value-setq (indent prefix number)
	  (text-fill-count-indent))))
    ;(msgbox "~S:~S:~S" indent prefix number)
    (when (or indent prefix number)
      (goto-bol)
      (when (and indent
		 (< 0 indent))
	(indent-to (text-fill-columns indent)))
      (if (or prefix number)
	  (cond (prefix
		 (if insert-prefix
		     (insert prefix)
		   (progn
		     (insert *text-fill-padding-char*)
		     (insert (substring prefix 1 (length prefix)))
		     (goto-eol))))
		(number
		 (if insert-prefix
		     (insert (text-fill-number-increment number))
		   (progn
		     (insert (text-fill-conv-padding-char (text-fill-padding-space (length number))))
		     (goto-eol)))))
	(goto-eol)))))

(defun text-fill-columns (indent)
  (* indent *text-fill-tab-columns*))

(defun text-fill-number-increment (number)
  (let ((len (length number)))
    (if (string-match *text-fill-number-regexp* number)
	(let ((num (parse-integer (match-string 1)))
	      (rest (substring number (match-end 1) len)))
	  (format nil "~D~A" (1+ num) rest))
      (text-fill-conv-padding-char (text-fill-padding-space len)))))

(defun text-fill-conv-padding-char (str)
  (let ((indent-string (text-fill-indent-string)))
    (substitute-string str (concat "^" indent-string) *text-fill-padding-char*)))

(defun text-fill-indent-string ()
  (text-fill-padding-tab *text-fill-indent-columns*))

(defun text-fill-padding-tab (len)
  (let ((str ""))
    (dotimes (i len)
      (setq str (concat str "\t")))
    str))

(defun text-fill-padding-space (len)
  (format nil "~VA" len ""))

(defun text-fill-indent-plus ()
  "インデント量を増やす"
  (interactive)
  (let ((bolp (bolp)))
    (multiple-value-bind (indent prefix number)
	(text-fill-count-indent)
      (save-excursion
	;(msgbox "~S:~S:~S" indent prefix number)
	;(msgbox "~S:~S" fill-column (text-fill-columns (+ indent *text-fill-indent-columns*)))
	(when (<= fill-column (text-fill-columns (+ indent *text-fill-indent-columns*)))
	  (message "これ以上インデントできまへん")
	  (return-from text-fill-indent-plus))
	(goto-bol)
	(unless (or prefix number)
	  (when (looking-at *text-fill-continue-regexp*)
	    (text-fill-back-to-start indent)))
	(insert "\t")
	(multiple-value-bind (indent2 prefix2 number2)
	    (text-fill-count-indent)
	  (when prefix2
	    (text-fill-prefix-char-change (+ indent *text-fill-indent-columns*))))
	(text-fill-re-format-line)))))

(defun text-fill-prefix-char (indent)
  (if (or (not indent)
	  (= indent 0))
      (car *text-fill-prefix-chars*)
    (let ((num (floor indent *text-fill-indent-columns*)))
      (nth (mod num (list-length *text-fill-prefix-chars*))
	   *text-fill-prefix-chars*))))

(defun text-fill-prefix-char-change (indent)
  "インデントの行頭文字を挿入・置換する"
  (interactive "p")
  (let (pos)
    (save-excursion
      (goto-bol)
      (skip-chars-forward "\t")
      (when (looking-at *text-fill-prefix-regexp*)
	(delete-char 1))
      (insert (text-fill-prefix-char indent))
      (setq pos (1- (point))))
    (when (equal pos (point))
      (forward-char 1))))

(defun text-fill-insert-current-prefix-char (&optional indent-number)
  "現在のインデントの行頭文字を挿入する"
  (interactive "p")
  (multiple-value-bind (indent prefix number)
      (text-fill-count-indent)
    (text-fill-prefix-char-change (or indent-number indent))))

(defun text-fill-indent-minus ()
  "インデント量を減らす"
  (interactive)
  (multiple-value-bind (indent prefix number)
      (text-fill-count-indent)
    (save-excursion
      (goto-bol)
      (unless (or prefix number)
	(when (looking-at *text-fill-continue-regexp*)
	  (text-fill-back-to-start indent)))
      (when (looking-for (text-fill-indent-string))
	(delete-char *text-fill-indent-columns*))
      (multiple-value-bind (indent2 prefix2 number2)
	  (text-fill-count-indent)
	(when (and prefix2
		   indent
		   (< 0 indent))
	  (text-fill-prefix-char-change (- indent *text-fill-indent-columns*))))
      (text-fill-re-format-line))))

(defun text-fill-re-format-line ()
  (interactive)
  (let (beg end)
    (save-excursion
      (goto-bol)
      (setq beg (point))
      (while (and (forward-line 1)
		  (looking-at *text-fill-continue-regexp*))
	(delete-region (point)
		       (progn
			 (skip-chars-forward "\t ")
			 (point)))
	(delete-backward-char))
      (setq end (point))
      ;(msgbox "~S-~S" beg end)
      (fill-region-as-paragraph beg end))))

(defun text-fill-newline-and-indent ()
  "改行した時にインデントする"
  (interactive)
  (let ((bolp (bolp)))
    (insert "\n")
    (unless bolp
      (text-fill-indent (eolp)))))

(defun text-fill-count-indent ()
  (let (pos
	(indent 0)
	prefix
	number)
    (save-excursion
      (goto-bol)
      (when (looking-at *text-fill-start-regexp*)
	(goto-char (match-end 0))
	(setq indent (truncate (floor (current-column) *text-fill-tab-columns*))))
      (cond ((looking-at *text-fill-prefix-regexp*)
	     (setq prefix (match-string 0)))
	    ((looking-at *text-fill-number-regexp*)
	     (setq number (match-string 0)))))
    (values indent prefix number)))

(defun text-fill-mode (&optional (arg nil sv))
  "Text-Fill マイナーモード"
  (interactive "p")
  (toggle-mode '*text-fill-mode* arg sv)
  (update-mode-line t)
  (if *text-fill-mode*
      (progn
	(make-local-variable 'ed::auto-fill-hook)
	(add-hook 'ed::auto-fill-hook #'text-fill-indent)
	(make-local-variable 'ed::fill-region-hook)
	(add-hook 'ed::fill-region-hook #'text-fill-indent)
	(make-local-variable 'ed::indent-tabs-mode)
	(setq ed::indent-tabs-mode *text-fill-indent-tabs-mode*)
	(set-tab-columns *text-fill-tab-columns* (selected-buffer))
	(setq *text-fill-prefix-regexp*
	      (format nil "\\([~{~A~}]\\) *" *text-fill-prefix-chars*))
	(auto-fill-mode t)
	(set-minor-mode-map *text-fill-mode-map*))
    (progn
      (unset-minor-mode-map *text-fill-mode-map*)
      (auto-fill-mode nil)
      (set-tab-columns *tab-columns* (selected-buffer))
      (kill-local-variable 'ed::auto-fill-hook)
      (kill-local-variable 'ed::fill-region-hook)
      (kill-local-variable 'ed::indent-tabs-mode)))
  t)

(pushnew '(*text-fill-mode* . "TFill") *minor-mode-alist* :key #'car)