;;; h2v.el

;;; Copyright 1995 Katsumi Yamaoka <yamaoka@ga.sony.co.jp>

;;; このファイルを load-path の下に置いて byte-compile-file したら
;;; .emacs には
;;;
;;;(autoload 'h2v-region "h2v" "領域を縦書きにします。" t)
;;;(autoload 'h2v-buffer "h2v" "バッファ全体を縦書きにします。" t)
;;;
;;; と書いて下さい。これで領域を指定してから M-x h2v-region とタイプ
;;; するか、M-x h2v-buffer とタイプすると使えます。

(provide 'h2v)

(defvar h2v-fill-column 70 "* 縦書きの横幅を指定します。")

(setq h2v-replace-string-alist-1
      '(
	("：" . "‥")
	("；" . "‥")
	("ー" . "｜")
	("―" . "｜")
	("／" . "＼")
	("＼" . "／")
	("〜" . "｜")
	("｜" . "―")
	("…" . "：")
	("‥" . "：")
	("（" . "∧")
	("）" . "∨")
	("〔" . "∧")
	("〕" . "∨")
	("［" . "∧")
	("］" . "∨")
	("｛" . "∧")
	("｝" . "∨")
	("《" . "∧")
	("》" . "∨")
	("「" . "┐")
	("」" . "└")
	("『" . "┓")
	("』" . "┗")
	("−" . "｜")
	("＝" . "‖")
	("＜" . "∧")
	("＞" . "∨")
	("→" . "↓")
	("←" . "↑")
	("↑" . "→")
	("↓" . "←")
	("⊂" . "∩")
	("⊃" . "∪")
	("∪" . "⊂")
	("∩" . "⊃")
	("≪" . "∧")
	("≫" . "∨")
	("─" . "│")
	("│" . "─")
	("┌" . "┐")
	("┐" . "┘")
	("┘" . "└")
	("└" . "┌")
	("├" . "┬")
	("┬" . "┤")
	("┤" . "┴")
	("┴" . "├")
	("━" . "┃")
	("┃" . "━")
	("┏" . "┓")
	("┓" . "┛")
	("┛" . "┗")
	("┗" . "┏")
	("┣" . "┳")
	("┳" . "┫")
	("┫" . "┻")
	("┻" . "┣")
	("┠" . "┯")
	("┯" . "┨")
	("┨" . "┷")
	("┷" . "┠")
	("┿" . "╂")
	("┝" . "┰")
	("┰" . "┥")
	("┥" . "┸")
	("┸" . "┝")
	("╂" . "┿")
	))

(setq h2v-replace-string-alist-2
      '(
	("　" . "  ")
	("、" . "ヽ")
	("。" . "°")
	("，" . " '")
	("．" . "°")
	))

(setq h2v-replace-string-alist-3
      '(
	(" ' " . "  '")
	(" └" . "└ ")
	(" ┗" . "┗ ")
	("￣" . " |")
	("＿" . "| ")
	("ヽ "  . " ヽ")
	("°  " . "  #°#")
	("ぁ " . " ぁ")
	("ぃ " . " ぃ")
	("ぅ " . " ぅ")
	("ぇ " . " ぇ")
	("ぉ " . " ぉ")
	("っ " . " っ")
	("ゃ " . " ゃ")
	("ゅ " . " ゅ")
	("ょ " . " ょ")
	("ゎ " . " ゎ")
	("ァ " . " ァ")
	("ィ " . " ィ")
	("ゥ " . " ゥ")
	("ェ " . " ェ")
	("ォ " . " ォ")
	("ッ " . " ッ")
	("ャ " . " ャ")
	("ュ " . " ュ")
	("ョ " . " ョ")
	("ヮ " . " ヮ")
	("ヵ " . " ヵ")
	("ヶ " . " ヶ")
	("┐ " . " ┐")
	("┓ " . " ┓")
	))

(setq h2v-search-regexp-1
      (let ((h2v-alist (cdr h2v-replace-string-alist-1))
	    (str (car (car h2v-replace-string-alist-1))))
	(while h2v-alist
	  (setq str (concat str "\\|" (car (car h2v-alist))))
	  (setq h2v-alist (cdr h2v-alist))
	  )
	str))

(setq h2v-search-regexp-2
      (let ((h2v-alist (cdr h2v-replace-string-alist-2))
	    (str (car (car h2v-replace-string-alist-2))))
	(while h2v-alist
	  (setq str (concat str "\\|" (car (car h2v-alist))))
	  (setq h2v-alist (cdr h2v-alist))
	  )
	str))

(setq h2v-search-regexp-3
      (let ((h2v-alist (cdr h2v-replace-string-alist-3))
	    (str (car (car h2v-replace-string-alist-3))))
	(while h2v-alist
	  (setq str (concat str "\\|" (car (car h2v-alist))))
	  (setq h2v-alist (cdr h2v-alist))
	  )
	str))

(defun h2v-region (beg end)
  "指定された領域を縦書きに変更します。"
  (interactive "r")
  (let ((obuf (current-buffer))
	(hbuf (generate-new-buffer "*h2v-h*"))
	(vbuf (generate-new-buffer "*h2v-v*"))
	start-column str
	(width 0)
	(div (cond ((boundp 'MULE) 2) (t 1)))
	eol col
	tmp-beg tmp-end
	(max-col (+ 1 (* (/ h2v-fill-column 3) 3)))
	num
	)
    (goto-char beg)
    (setq start-column (current-column))
    (setq str (buffer-substring beg end))
    (switch-to-buffer hbuf)
    (insert-char 32 start-column)
    (insert str)
    (cond ((not (string-equal
		 (buffer-substring (- (point-max) 1) (point-max)) "\n"))
	   (goto-char (point-max))
	   (insert "\n")))
    (goto-char (point-min))
    (replace-string "　" "  ")
    (untabify (point-min) (point-max))
    (zenkaku-region (point-min) (point-max))
;    (goto-char (point-min))
;    (replace-string "　　" "　")
    (goto-char (point-min))
    (while (< (point) (point-max))
      (end-of-line)
      (setq width (max width (current-column)))
      (next-line 1)
      )
    (goto-char (point-min))
    (while (< (point) (point-max))
      (end-of-line)
      (insert-char (string-to-char "　") (/ (- width (current-column)) div))
      (next-line 1)
      )
    (switch-to-buffer vbuf)
    (insert-char ?\n (/ width 2))
    (goto-char (point-min))
    (switch-to-buffer hbuf)
    (while (> (point) (point-min))
      (previous-line 1)
      (end-of-line)
      (setq eol (point))
      (beginning-of-line)
      (while (< (point) eol)
	(setq col (point))
	(forward-char)
	(setq str (buffer-substring (+ 1 col) (point)))
	(switch-to-buffer vbuf)
	(insert str " ")
	(next-line 1)
	(switch-to-buffer hbuf)
	)
      (switch-to-buffer vbuf)
      (goto-char (point-min))
      (end-of-line)
      (switch-to-buffer hbuf)
      (beginning-of-line)
      )
    (switch-to-buffer vbuf)
    (goto-char (point-min))
    (setq tmp-beg (point))
    (end-of-line)
    (while (> (setq num (- (current-column) max-col)) 0)
      (move-to-column num)
      (re-search-forward "[^ ]")
      (copy-rectangle-to-register ?H (match-beginning 0) (- (point-max) 1) t)
      (goto-char (point-max))
      (setq tmp-end (point))
      (insert-register ?H)
      (goto-char (point-max))
      (insert "\n")
      (kill-region tmp-end (point-max))
      (goto-char tmp-beg)
      (yank)
      (insert "\n")
      (setq tmp-beg (point))
      (end-of-line)
      )
    (while (< (point) (point-max))
      (beginning-of-line)
      (insert-char 32 (- (- num) 1))
      (next-line 1)
      )
    (goto-char (point-min))
    (while (re-search-forward h2v-search-regexp-1 nil t)
      (replace-match
       (concat "#"
	       (cdr (assoc (buffer-substring (match-beginning 0) (match-end 0))
			   h2v-replace-string-alist-1))
	       "#")
       ))
    (goto-char (point-min))
    (while (re-search-forward "#[^#]+#" nil t)
      (replace-match
       (buffer-substring (+ (match-beginning 0) 1) (- (match-end 0) 1))
       ))
    (goto-char (point-min))
    (while (re-search-forward h2v-search-regexp-2 nil t)
      (replace-match
       (cdr (assoc (buffer-substring (match-beginning 0) (match-end 0))
		   h2v-replace-string-alist-2))
       ))
    (goto-char (point-min))
    (while (re-search-forward h2v-search-regexp-3 nil t)
      (replace-match
       (cdr (assoc (buffer-substring (match-beginning 0) (match-end 0))
		   h2v-replace-string-alist-3))
       ))

    (goto-char (point-min))
    (while (re-search-forward "° \\|#°#[ ]*\n" nil t)
      (setq str (buffer-substring (match-beginning 0) (match-end 0)))
      (replace-match "")
      (insert (cond ((string-match "° " str) " °")
		    ((string-match "#°#[ ]*\n" str) "#°#\n")))
      )

    (goto-char (point-min))
    (while (re-search-forward "#°#\\|° *$\\| +$" nil t)
      (setq str (buffer-substring (match-beginning 0) (match-end 0)))
      (replace-match "")
      (cond ((string-match "#°#" str) (insert "°"))
	    ((string-match "° *" str) (insert " °"))
	    ))
    (goto-char (point-min))
    (while (search-forward "\n\n\n" nil t)
      (goto-char (match-beginning 0))
      (delete-char 2)
      (if (eq (+ (point) 2) (point-max))
	  (delete-char 1)
	))
;    (tabify (point-min) (point-max))
    (setq str (buffer-string))
    (switch-to-buffer obuf)
    (kill-buffer hbuf)
    (kill-buffer vbuf)
    (setq buffer-read-only nil)
    (delete-region beg end)
    (insert str)
    ))

(defun h2v-buffer ()
  "バッファ全体を縦書きに変更します。"
  (interactive)
  (h2v-region (point-min) (point-max))
  )

;;; h2v.el ends here.