;;; lisp file for xyzzy ver0.2.2.233
;;; 逸見さん作 outline.l remodel ver0.1.0.8 // crayonzen [2006-11-08]12:25:40(+0900)

#|
.xyzzy または siteinit.l に
(require "outline")
と書き込む。
（siteinit.l はファイルをバイトコンパイル( M-x: byte-compile-file )して、
ダンプファイル（xyzzy.w98 や xyzzy.w2k など）を削除してxyzzy再起動）

outline ;;選択範囲の文字列で。無いときはキー入力待ち。例："^■"（行頭"^"の"■"をアウトライン）
outline-text ;;テキスト用。下記の設定のキャラによる。
outline-lisp ;;Lisp用。下記の設定のキャラによる。
outline-paragraph ;;段落用（空白行で）。
outline-jump ;;Enter　F10　Dwon　Up　のキーでジャンプ（ライン番号によるのでやや曖昧）。
outline-margin ;;一時的にアウトラインのウィンドウの幅変更。
outline-mode ;;アウトラインモードにする。
|#
;;;キー割り当ての例
;;;(global-set-key #\C-F10 'outline)

(provide "outline")

(in-package "editor")

(export '(outline
	  outline-text
	  outline-lisp
	  outline-paragraph
	  outline-jump
	  outline-margin
	  outline-mouse-left-up
	  outline-mode

	  *outline-pattern*
	  *outline-mode-hook*

	  *outline-menus*))

(defvar *outline-mode-hook* nil)

(defvar *outline-pattern* "^[■□●○◎・]")

;;;テキスト
(defvar *outline-pattern-text* "^[【■□▲△▼▽◆◇○◎●※☆★・]")

;;;Lisp
(defvar *outline-pattern-lisp* "^\\((provide\\|(export\\|(def\\)")
;(defvar *outline-pattern-lisp* "^\\(;;;\\| *\"\\|(provide\\|(def\\)")

;;;段落　行空白による
(defvar *outline-pattern-paragraph* "^\\( \\|　\\|\t\\)*?\$")

(defvar *outline-header* "Outline-")
(defvar *outline-margin* 30)

(defvar *outline-mode-map* nil)
(unless *outline-mode-map*
  (setq *outline-mode-map* (make-sparse-keymap))
  (define-key *outline-mode-map* #\F10 'outline-jump)
  (define-key *outline-mode-map* #\RET 'outline-jump)
  (define-key *outline-mode-map* #\Down 'outline-jump-down)
  (define-key *outline-mode-map* #\Up 'outline-jump-up)
  (define-key *outline-mode-map* #\LBtnUp 'outline-mouse-left-up)
  )

;;;選択文字列。または入力待ち。
(defun outline ()
  (interactive "*")
  (cond ((pre-selection-p)
	 ;;selection
	 (let ((strpattern (buffer-substring (setq from (selection-mark))
					     (setq to (selection-point)))))
	   (setq strpattern (regexp-quote strpattern))
	   (save-excursion
	     (if (> from to)
		 (rotatef from to))
	     (goto-char from)
	     (if (bolp)
		 (setq strpattern (concat "^" strpattern))
	       (progn
		 (goto-char to)
		 (if (eolp)
		     (setq strpattern (concat strpattern "$")))
		 )
	       )
	     )
	   (outline-make strpattern))
	 )
	(t
	 ;;input
	 (let ((strpattern (read-string "outline(regexp): " :default *outline-pattern*)))
	   (unless (string= strpattern "")
	     (outline-make strpattern)))
	 )
	)
  )

(defun outline-text ()
  (interactive "*")
  (outline-make *outline-pattern-text*)
  )

(defun outline-lisp ()
  (interactive "*")
  (outline-make *outline-pattern-lisp*)
  )

(defun outline-paragraph ()
  (interactive)
  (outline-make *outline-pattern-paragraph* "paragraph")
  )

;;;Outlineのバッファの名前を作る
(defun outline-buffer-name (buf)
  (if (bufferp buf)
      (setq buf (buffer-name buf)))
  (concat *outline-header* buf))

;;;Outlineのバッファを作って出力
(defun outline-make (&optional (pattern) (type nil))
  (interactive)
  (long-operation
    (let ((sb (selected-buffer))
	  (sbwin (selected-window))
	  ob obname)
      (setq obname (outline-buffer-name sb))
      (save-excursion

	;;他のウィンドウを閉じてからウィンドウを分割
	(if (setq ob (find-buffer obname))
	    (progn
	      (unless (setq obwin (get-buffer-window ob))
		(delete-other-windows)
		(outline-split-window)
		(setq obwin (selected-window))
		))
	  (progn
	    (delete-other-windows)
	    (setq ob (create-new-buffer obname))
	    (outline-split-window)
	    (setq obwin (selected-window))))

	;;既存のバッファがあってもウインドウを持っていなければ分割
	;;既存のバッファがなければバッファを作ってウィンドウ分割
	;;	(if (setq ob (find-buffer obname))
	;;	    (progn
	;;	      (unless (setq obwin (get-buffer-window ob))
	;;		(outline-split-window)
	;;		(setq obwin (selected-window))
	;;		(other-window)
	;;		))
	;;	  (progn
	;;	    (setq ob (create-new-buffer obname))
	;;	    (outline-split-window)
	;;	    (setq obwin (selected-window))))

	;;バッファ内容を全クリア
	(set-buffer ob)
	(delete-region (point-min) (point-max))
	;;出力：通常用と段落用のタイプに分岐
	(set-buffer sb)
	(with-output-to-buffer (obname nil)
	  (goto-char (point-min))
	  (if (equal type "paragraph")
	      (outline-output-paragraph pattern)
	    (outline-output pattern)))
	;;Outline用のモードをセット
	(set-buffer ob)
	(outline-mode)
	)
      ;;移動
      (set-window obwin)
      (set-buffer ob)
      (message "completed. JUMP Key: Enter or F10")
      ))
  )

;;;ウィンドウ分割
;横分割
;;(defun outline-split-window ()
;;  (let ()
;;    (split-window (- (floor (window-height) 2) 2))
;;    (selected-buffer))
;;  )
;;
;;
;;(defun outline-split-window ()
;;  (let ()
;;    (if (>= (window-height) (+ *outline-margin* *outline-margin*))
;;	(split-window *outline-margin* nil)
;;	(split-window (truncate (window-height) 2) nil))
;;    (selected-buffer))
;;  )

;縦分割
(defun outline-split-window ()
  (let ()
    (split-window *outline-margin* t)
    (selected-buffer))
  )
;;
;;(defun outline-split-window ()
;;  (let ()
;;    (if (>= (window-width) (+ *outline-margin* *outline-margin*))
;;	(split-window *outline-margin* t)
;;      (split-window (truncate (window-width) 2) t))
;;    (selected-buffer))
;;  )

;;;出力：通常用
(defun outline-output (pattern)
  (while (scan-buffer pattern :regexp t)
    (format t "~D:~A~%" (current-line-number) (buffer-substring (progn (goto-bol) (point))
								(progn (goto-eol) (point))))
    (or (forward-char 1)
	(return)))
  )

;;;出力；段落用
(defun outline-output-paragraph (pattern)
  (format t "~D:~A~%" (current-line-number) (buffer-substring (progn (goto-bol) (point))
							      (progn (goto-eol) (point))))
  (while (scan-buffer pattern :regexp t)
    (unless (forward-line) (return))
    (unless (eql "^\$"
		 (setq linestring (buffer-substring(progn (goto-bol) (point))
						   (progn (goto-eol) (point)))))
      (format t "~D:~A~%" (current-line-number) linestring)
      )
    (forward-line -1) (goto-eol)
    (or (forward-char 1)
	(return)))
  )

;;;本文のジャンプ
(defun outline-jump-down ()
  (interactive)
  (if (next-virtual-line)
      (outline-jump)))

(defun outline-jump-up ()
  (interactive)
  (if (previous-virtual-line)
      (outline-jump)))

(defun outline-jump ()
  (interactive)
  (let ((sw (selected-window))
	(bname (substring (buffer-name (selected-buffer)) (length *outline-header*) nil))
	(stringline nil))
    (save-excursion
      (setq stringline (buffer-substring (progn (goto-bol) (point))
					 (progn (goto-eol) (point))))
      (setq mp (string-match ":" stringline))
      (if (null mp)
	  (return-from outline-jump)
	(progn
	  (setq headlinenumber (parse-integer (substring stringline 0 mp) :junk-allowed t))
	  (if (null headlinenumber)
	      (return-from outline-jump)
	    (progn
	      (setq headlinestring (substring stringline (incf mp) nil))

	      (cond ((= (count-windows 'foo) 1)
		     (outline-split-window)
		     (other-window)
		     (set-buffer bname))
		    (t (pop-to-buffer bname)))

	      ;(goto-char (point-min))
	      ;(scan-buffer headlinestring)
	      (goto-line headlinenumber)
	      (recenter 0)
	      (set-window sw)))))
      )
    (reverse-region-mark-line)
    )
  )

(defun reverse-region-mark-line ()
  (let ((curpoint (point)))
    (setq from (progn (goto-eol) (point)))
    (setq to (progn (goto-bol) (point)))
    (reverse-region from to t)
    (goto-char curpoint))
  )

;;;横幅の設定変更
(defun outline-margin (n)
  (interactive "nmargin: " :default *outline-margin*)
  (setq *outline-margin* n))

(defun outline-mouse-left-up ()
  (interactive)
  (continue-pre-selection)
  (selection-leave)
  (if (and (eq buffer-mode 'outline-mode)
	   (= *last-mouse-click-count* 2))	  
      (outline-jump))
  )

;;;モード設定
(defun outline-mode ()
  (interactive)
  (kill-all-local-variables)
  ;;(setq buffer-read-only t)
  (set-buffer-fold-width nil)
  (set-buffer-modified-p nil)
  (setq buffer-mode 'outline-mode)
  (setq mode-name "Outline")
  (use-keymap *outline-mode-map*)
  (run-hooks '*outline-mode-hook*))

;;;;;;;;;;;;;;;;menu
(defvar *outline-menus* nil)

(defun init-outline-popup-menu ()
  (or *outline-menus*
      (setq *outline-menus* (create-popup-menu)))

  (setq *outline-menus*
	(define-popup-menu
	  (:item nil"選択範囲（行頭行末区別します）または入力(&S)"
	   'outline)
	  (:item nil (concat "テキスト" *outline-pattern-text* "(&T)")
	   'outline-text)
	  (:item nil "Lisp(&L)"
	   'outline-lisp)
	  (:item nil "段落（空白行による）(&P)"
	   'outline-paragraph)
	  )))

;;;;;;;;;;;;;;;; 挿入メニュー６　insert menu tools ツール
(add-hook '*init-app-menus-hook*
	  #'(lambda ()
	      (when (and *app-menu*
			 (setq menu (get-menu *app-menu* 'ed::tools)))
		(init-outline-popup-menu)
		(setq ip -1)
		(while (get-menu menu (incf ip) t))

		(insert-menu-separator menu ip 'outline-menu-sep1)
		(insert-popup-menu menu (incf ip) *outline-menus* "アウトライン(&L)")
		)
	      )
	  )
