(defvar-local *olt-action-immediately* nil
"即時ノード実行")
(defvar-local *olt-chase-cursor* nil
"カーソルに追従")
(defvar-local *olt-range-type-narrow* nil
"範囲タイプ：狭")
(defvar-local *olt-view-restriction* nil
"表示範囲制限")
(defvar-local *olt-view-emphasis* nil
"強調表示")
(defvar-local *olt-make-function* 'olt-make-regexp
"アウトライン作成関数")
(defvar-local *olt-buffer-latest* nil)
(defvar *olt-name* "Outline-Tree"
"outline-tree の表示名")
(defvar *olt-short-name* "OLT"
"outline-tree の省略表示名")
(defvar *olt-long-name* *olt-name*
"outline-tree の非省略表示名")
(defvar *olt-config-file* "~/.olt"
"outline-tree 設定ファイルパス")
(defvar *olt-width* 200
"treeview の幅")
(defvar *olt-height* 100
"treeview の高さ")
(defvar *olt-position* XPIS_LEFT
"treeview の表示位置")
(defvar *olt-add-treeview-window* :enlarge
"nil, :fix, :enlarge (t)")
(defvar *olt-close-unnecessary-treeview* t
"表示ノードがなければ treeview を閉じる")
(defvar *olt-save-size* t
"treeview を閉じる際、幅、高さを記録")
(defvar *olt-treeview-style-hasbuttons* t
"treeview にボタンを表示")
(defvar *olt-treeview-style-haslines* t
"treeview にラインを表示")
(defvar *olt-treeview-style-linesatroot* t
"treeview にライン・ボタンをルートから表示")
(defvar *olt-treeview-style-checkboxes* nil
"treeview にチェックボックスを表示")
(defvar *olt-treeview-style-trackselect* t
"treeview でトラックセレクト")
(defvar *olt-treeview-style-fullrowselect* nil
"treeview で一行選択表示")
(defvar *olt-treeview-style-notooltips* nil
"treeview でツールチップを表示しない")
(defvar *olt-text-color-manual-p* nil)
(defvar *olt-text-color* nil)
(defvar *olt-bk-color-manual-p* nil)
(defvar *olt-bk-color* nil)
(defvar *olt-modify-text-color-manual-p* nil)
(defvar *olt-modify-text-color* nil)
(defvar *olt-modify-bk-color-manual-p* nil)
(defvar *olt-modify-bk-color* nil)
(defvar *olt-treeview-indent-manual-p* nil)
(defvar *olt-treeview-indent* nil)
(defvar *olt-treeview-item-height-manual-p* nil)
(defvar *olt-treeview-item-height* nil)
(defvar *olt-font-facename-manual-p* nil)
(defvar *olt-font-facename-default* nil)
(defvar *olt-font-facename* nil)
(defvar *olt-font-height-manual-p* nil)
(defvar *olt-font-height-default* 12)
(defvar *olt-font-height* nil)
(defvar *olt-font-weight-manual-p* nil)
(defvar *olt-font-weight-default* 0)
(defvar *olt-font-weight* nil)
(defvar *olt-font-italic* nil)
(defvar *olt-font-underline* nil)
(defvar *olt-tool-bar-local* nil
"ツールバーではローカル設定")
(defvar *olt-emphasis-attribute* '(:background 3 :prefix #\T :extend t)
"強調表示属性")
(defvar *olt-make-expand* :depth "t, nil, :depth")
(defvar *olt-make-expand-depth* 2)
(defvar *olt-chase-expand* :depth "t, nil, :depth")
(defvar *olt-chase-expand-depth* 3)
(defvar *olt-recenter* :line "t, nil, :line")
(defvar *olt-recenter-line* 3)
(defvar *olt-treeview-recenter* nil "t, nil, :line")
(defvar *olt-treeview-recenter-line* 3)
(defvar *olt-treeview-scroll-margin* 0)
(defvar *olt-select-node-delay-sec* 0.01 "olt-select-node-delay 用変数")
(defvar *olt-fix-map* nil "outline-tree: treeview keymap (デフォルト動作対策)")
(defvar *olt-map* nil "outline-tree: treeview keymap")
(defvar *olt-header-node-title* "<先頭>")
(defvar *olt-dummy-node-title* "<dummy>")
(defvar *olt-treeview-style-icon* t)
(defvar *olt-icon-directory* (merge-pathnames "site-lisp/olt/icon" (si:system-root))
"olt: icon ディレクトリ")
(defvar *olt-item-icon* nil)
(defvar *olt-selected-item-icon* nil)
(defvar *olt-buffer-icon* nil)
(defvar *olt-file-icon* nil)
(defvar *olt-section-icon* nil)
(defvar *olt-dependent-icon* nil)
(defvar *olt-info-icon* nil)
(defvar *olt-update-item-icon* nil)
(defvar *olt-open-hook* nil)
(defvar *olt-close-hook* nil)
(defvar *olt-make-hook* nil)
(defvar *olt-delete-hook* nil)
(defvar *olt-focus-editor-hook* nil)
(defvar *olt-focus-outline-hook* nil)
(defvar *olt-uninstall-hook* nil)
(defvar *olt-tag* 'olt
"強調表示の際の識別タグ")
(defvar *olt-hash* (make-hash-table))
(defvar *olt-buffer-hash* (make-hash-table))
(defvar *olt-make-function-alist* nil)
(defvar *olt-shutting-hook* nil)
(defvar *olt-opening-hook* nil)
(defvar *olt-window-size-min* 5)
(defvar *olt-window-size-threshold* 20)
(defvar *olt-window-size-default* 200)
(defvar *before-olt-make-only-buffer-node-hook* nil)
(defvar *olt-except-buffer-name-regexp-list* nil)
(defvar *olt-except-commands-for-select-cursor-related-node* nil)
(defvar *olt-node-begin* "node: *")
(defvar *olt-node-end* " *:end")
(defvar *olt-sync-local-variables-list*
'((*olt-action-immediately*
*olt-chase-cursor*
*olt-range-type-narrow*
*olt-view-restriction*
*olt-view-emphasis*)))
(defvar *olt-escape-char-alist*
'(("\n" . "\\\\n")
("\r" . "\\\\r")
("\t" . "\\\\t")
("\f" . "\\\\f")))
(defvar *olt-option-prop-page* nil)
(defvar *olt-option-prop-page-no* nil)
(defvar *olt-make-function-auto-mode-parameter* nil)
(defun olt-message (fmt &rest args)
"メッセージをステータスバーに表示"
(apply #'message (concat *olt-short-name* ": " fmt) args))
(defun olt-minibuffer-prompt (fmt &rest args)
"書式に従ってミニバッファにメッセージを表示"
(apply #'minibuffer-prompt (concat *olt-short-name* ": " fmt) args))
(defun olt-config-load ()
"設定ファイルを読み込む"
(when (and *olt-config-file*
(file-exist-p *olt-config-file*))
(load *olt-config-file*)
(setq loaded-p t)))
(defun olt-config-loaded-p ()
"設定ファイルを読み込み済み"
loaded-p)
(defun olt-shutting-p ()
(and (treeview-open-p)
(or (and (find (treeview-get-position) (list XPIS_LEFT XPIS_RIGHT))
(<= (olt-get-window-width (treeview-get-hwnd)) *olt-window-size-threshold*))
(and (find (treeview-get-position) (list XPIS_TOP XPIS_BOTTOM))
(<= (olt-get-window-height (treeview-get-hwnd)) *olt-window-size-threshold*)))))
(defun olt-insert-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter))
(defun olt-insert-buffer-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter
:icon *olt-buffer-icon* :sicon *olt-buffer-icon*))
(defun olt-insert-normal-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter
:icon *olt-item-icon* :sicon *olt-selected-item-icon*))
(defun olt-insert-dependent-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter
:icon *olt-dependent-icon* :sicon *olt-selected-item-icon*))
(defun olt-insert-info-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter
:icon *olt-info-icon* :sicon *olt-info-icon*))
(defun olt-insert-section-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter
:icon *olt-section-icon* :sicon *olt-section-icon*))
(defun olt-insert-update-item (text parent &key (insertafter TVI_LAST))
(treeview-insert-item text parent :insertafter insertafter
:icon *olt-update-item-icon* :sicon *olt-selected-item-icon*))
(defun olt-treeview-modify-style ()
"treeview の style を変更"
(unless (treeview-open-p)
(return-from olt-treeview-modify-style nil))
(treeview-modify-style
(logior
(if (not *olt-treeview-style-hasbuttons*) TVS_HASBUTTONS 0)
(if (not *olt-treeview-style-haslines*) TVS_HASLINES 0)
(if (not *olt-treeview-style-linesatroot*) TVS_LINESATROOT 0)
(if (not *olt-treeview-style-notooltips*) TVS_NOTOOLTIPS 0)
(if (not *olt-treeview-style-checkboxes*) TVS_CHECKBOXES 0)
(if (not *olt-treeview-style-trackselect*) TVS_TRACKSELECT 0)
(if (not *olt-treeview-style-fullrowselect*) TVS_FULLROWSELECT 0)
)
(logior
(if *olt-treeview-style-hasbuttons* TVS_HASBUTTONS 0)
(if *olt-treeview-style-haslines* TVS_HASLINES 0)
(if *olt-treeview-style-linesatroot* TVS_LINESATROOT 0)
TVS_SHOWSELALWAYS
(if *olt-treeview-style-notooltips* TVS_NOTOOLTIPS 0)
(if *olt-treeview-style-checkboxes* TVS_CHECKBOXES 0)
(if *olt-treeview-style-trackselect* TVS_TRACKSELECT 0)
(if *olt-treeview-style-fullrowselect* TVS_FULLROWSELECT 0)
)
0)
(olt-treeview-modify-icon)
(olt-treeview-modify-color)
(olt-treeview-modify-font)
(cond
((not *olt-treeview-item-height-manual-p*)
(treeview-set-item-height -1))
((not (eql (treeview-get-item-height) *olt-treeview-item-height*))
(treeview-set-item-height *olt-treeview-item-height*)))
(cond
((not *olt-treeview-indent-manual-p*)
(treeview-set-indent 0))
((not (eql (treeview-get-indent) *olt-treeview-indent*))
(treeview-set-indent *olt-treeview-indent*)))
)
(defun olt-treeview-modify-icon ()
"treeview の icon を変更"
(unless (treeview-open-p)
(return-from olt-treeview-modify-icon nil))
(if (and *olt-treeview-style-icon*
(file-exist-p *olt-icon-directory*)
(file-directory-p *olt-icon-directory*))
(progn
(setq *olt-item-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "item.ico" *olt-icon-directory*))))
(setq *olt-selected-item-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "selected-item.ico" *olt-icon-directory*))))
(setq *olt-dependent-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "dependent.ico" *olt-icon-directory*))))
(setq *olt-info-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "info.ico" *olt-icon-directory*))))
(setq *olt-buffer-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "buffer.ico" *olt-icon-directory*))))
(setq *olt-file-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "file.ico" *olt-icon-directory*))))
(setq *olt-section-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "section.ico" *olt-icon-directory*))))
(setq *olt-update-item-icon*
(treeview-add-file-icon
(map-slash-to-backslash (merge-pathnames "update.ico" *olt-icon-directory*))))
)
(progn
(treeview-remove-all-icons)
(setq *olt-item-icon* nil)
(setq *olt-selected-item-icon* nil)
(setq *olt-dependent-icon* nil)
(setq *olt-info-icon* nil)
(setq *olt-buffer-icon* nil)
(setq *olt-file-icon* nil)
(setq *olt-section-icon* nil)
(setq *olt-update-item-icon* nil))))
(defun olt-treeview-modify-color (&optional (modified-p nil sv))
"treeview の色を変更"
(unless (treeview-open-p)
(return-from olt-treeview-modify-color nil))
(unless sv
(setq modified-p (olt-get-modified-buffer-list)))
(treeview-set-bk-color
(cond
((and modified-p *olt-modify-bk-color-manual-p*)
*olt-modify-bk-color*)
(*olt-bk-color-manual-p*
*olt-bk-color*)
(t
nil)))
(treeview-set-text-color
(cond
((and modified-p *olt-modify-text-color-manual-p*)
*olt-modify-text-color*)
(*olt-text-color-manual-p*
*olt-text-color*)
(t
nil))))
(defun olt-treeview-modify-font ()
"treeview のフォントを変更"
(unless (treeview-open-p)
(return-from olt-treeview-modify-font nil))
(olt-set-font :font-facename (if *olt-font-facename-manual-p*
*olt-font-facename* *olt-font-facename-default*)
:font-height (if *olt-font-height-manual-p*
*olt-font-height* *olt-font-height-default*)
:font-weight (if *olt-font-weight-manual-p*
*olt-font-weight* *olt-font-weight-default*)
:font-italic *olt-font-italic*
:font-underline *olt-font-underline*))
(defun olt-except-buffer-name-match-p (buffer)
(unless (or (bufferp buffer)
(and (stringp buffer) (find-buffer buffer)))
(return-from olt-except-buffer-name-match-p nil))
(let ((name (buffer-name buffer)))
(dolist (regexp *olt-except-buffer-name-regexp-list*)
(when (string-match regexp name)
(return-from olt-except-buffer-name-match-p t)))))
(defun olt-get-buffer-list ()
(let (buffers)
(when (treeview-open-p)
(maphash #'(lambda (buffer hitem)
(push buffer buffers))
*olt-buffer-hash*))
buffers))
(defun olt-get-modified-buffer-list ()
(let (buffers)
(when (treeview-open-p)
(maphash #'(lambda (buffer hitem)
(if (and (not (deleted-buffer-p buffer))
(not (buffer-local-value buffer '*olt-buffer-latest*)))
(push buffer buffers)))
*olt-buffer-hash*))
buffers))
(defun olt-select-node-1 (base-hitem hitem-mover)
(let* ((selected-hitem (treeview-get-selected-item))
(window-line (treeview-get-window-line selected-hitem))
hitem scroll-margin recenter-arg need-not-recenter-p)
(when (or (and (eq base-hitem nil)
(treeview-hitem-valid-p
(setq hitem (funcall hitem-mover))))
(and (treeview-hitem-valid-p base-hitem)
(functionp hitem-mover)
(treeview-hitem-valid-p
(setq hitem (funcall hitem-mover base-hitem)))))
(cond
(*olt-treeview-recenter*
(setq recenter-arg (if (and (eq *olt-treeview-recenter* :line)
(integerp *olt-treeview-recenter-line*))
*olt-treeview-recenter-line* nil)))
(t
(setq scroll-margin (if (and (numberp *olt-treeview-scroll-margin*)
(integerp *olt-treeview-scroll-margin*)
(plusp *olt-treeview-scroll-margin*))
*olt-treeview-scroll-margin* nil))
(if scroll-margin
(progn
(setq scroll-margin
(min scroll-margin (truncate (treeview-window-height) 2)))
(cond
((treeview-hitem-equal selected-hitem hitem)
(setq need-not-recenter-p t))
((treeview-hitem-greaterp selected-hitem hitem)
(setq recenter-arg scroll-margin)
(cond
((<= window-line recenter-arg)
(setq recenter-arg window-line))
((>= (treeview-get-window-line hitem) recenter-arg)
(setq need-not-recenter-p t))))
(t
(setq recenter-arg (- (1- (treeview-window-height)) scroll-margin))
(cond
((>= window-line recenter-arg)
(setq recenter-arg window-line))
((< (treeview-get-window-line hitem) recenter-arg)
(setq need-not-recenter-p t))))))
(setq need-not-recenter-p t))))
(if (or need-not-recenter-p
(and (treeview-item-window-visible-p hitem)
(let ((scroll (treeview-recenter-scroll-height
hitem recenter-arg)))
(cond
((not (numberp scroll)) nil)
((zerop scroll) t)
((plusp scroll) (treeview-window-bottom-p))
(t (treeview-window-top-p))))))
(treeview-select-item hitem)
(olt-suppress-redraw
(treeview-select-item hitem)
(treeview-recenter recenter-arg))))
(if (olt-get-action-immediately hitem)
(olt-node-action hitem))))
(defun olt-get-buffer-related-buffer-node (&optional buffer)
"buffer に対応した buffer-node を取得。
対応するノードがなければ nil を返す。"
(when (treeview-open-p)
(unless (bufferp buffer)
(setq buffer (selected-buffer)))
(gethash buffer *olt-buffer-hash*)))
(defun olt-get-cursor-related-node (&optional (expand t))
"olt: ポイントの位置に対応したノードを取得。
EXPAND: t 可能な限り展開
<integer> 展開する階層レベル
上記以外 展開しない"
(labels ((olt-get-cursor-related-node-1 (parent-hitem position)
(unless (and (treeview-hitem-valid-p parent-hitem)
(integerp position))
(return-from olt-get-cursor-related-node-1 nil))
(let (hitem child-hitem value wide-range)
(when (not (zerop (treeview-item-has-children parent-hitem)))
(setq hitem (treeview-get-child-item parent-hitem))
(while (treeview-hitem-valid-p hitem)
(setq value (gethash hitem *olt-hash*))
(case (car value)
((:node :header-node :dependent-node)
(setq wide-range (nth 2 value))
(when (and wide-range
(<= (car wide-range) position)
(< position (cdr wide-range)))
(return-from olt-get-cursor-related-node-1
(or (olt-get-cursor-related-node-1 hitem position) hitem))))
(t
(setq child-hitem (olt-get-cursor-related-node-1 hitem position))
(if child-hitem
(return-from olt-get-cursor-related-node-1 child-hitem))))
(setq hitem (treeview-get-next-sibling-item hitem)))))
nil))
(when (treeview-open-p)
(let ((hitem (olt-get-buffer-related-buffer-node (selected-buffer))) child-hitem)
(when hitem
(setq child-hitem (olt-get-cursor-related-node-1 hitem (point)))
(when child-hitem
(setq hitem child-hitem))
(cond
((eq expand t))
((and (integerp expand)
(plusp expand))
(let ((i (- (treeview-get-depth hitem) expand))
(parent-hitem (treeview-get-parent-item hitem)))
(while (and (plusp i)
(treeview-hitem-valid-p parent-hitem)
(not (treeview-expand-p parent-hitem)))
(setq hitem parent-hitem
parent-hitem (treeview-get-parent-item hitem))
(decf i))))
(t
(let ((parent-hitem (treeview-get-parent-item hitem)))
(while (and (treeview-hitem-valid-p parent-hitem)
(not (treeview-expand-p parent-hitem)))
(setq hitem parent-hitem
parent-hitem (treeview-get-parent-item hitem)))))))
hitem))))
(defun olt-get-node-related-buffer (&optional (hitem (treeview-get-selected-item)))
(let (buffer)
(multiple-value-bind (hitem value)
(olt-get-parent-buffer-node hitem)
(when value
(setq buffer (nth 2 value))
buffer))))
(defun olt-get-jump-node-info ()
(save-excursion
(let ((opoint (point))
(bol-point (progn (goto-bol) (point)))
(eol-point (progn (goto-eol) (point)))
wide-begin wide-end narrow-begin narrow-end)
(if (scan-buffer *olt-node-begin* :regexp t
:reverse t :left-bound bol-point)
(progn
(setq wide-begin (match-beginning 0))
(setq narrow-begin (match-end 0)))
(return-from olt-get-jump-node-info (values nil nil nil)))
(goto-char wide-begin)
(if (scan-buffer *olt-node-end* :regexp t
:reverse nil :right-bound eol-point)
(progn
(setq wide-end (match-end 0))
(setq narrow-end (match-beginning 0)))
(return-from olt-get-jump-node-info (values nil nil nil)))
(if (and (<= wide-begin opoint) (< opoint wide-end))
(values (buffer-substring narrow-begin narrow-end)
wide-begin wide-end)
(values nil nil nil)))))
(defun olt-select-nodes-dialog (hitems)
(multiple-value-bind (result data)
(dialog-box
'(dialog 0 0 254 207
(:caption "outline-tree: ﾉｰﾄﾞｼﾞｬﾝﾌﾟ")
(:font 9 "ＭＳ Ｐゴシック")
(:control
(:listbox list nil #x50b10001 2 3 188 203)
(:button IDOK "移動(&G)" #x50030001 198 7 52 14)
(:button IDCANCEL "ｷｬﾝｾﾙ" #x50030000 198 27 52 14)))
(list (cons 'list (mapcar #'treeview-get-item-text hitems))
'(list . 0))
'((list :index t :must-match t :enable (IDOK))))
(when result
(nth (cdr (assoc 'list data)) hitems))))
(defun olt-set-action-immediately (arg &key local)
(olt-toggle-action-immediately :arg arg :local local))
(defun olt-set-chase (arg &key local)
(olt-toggle-chase :arg arg :local local))
(defun olt-set-range-type-narrow (arg &key local)
(olt-toggle-range-type-narrow :arg arg :local local))
(defun olt-set-view-restriction (arg &key local)
(olt-toggle-view-restriction :arg arg :local local))
(defun olt-set-view-emphasis (arg &key local)
(olt-toggle-view-emphasis :arg arg :local local))
(defun olt-set-hide-restricted-region (arg &key local)
(olt-toggle-hide-restricted-region :arg arg :local local))
(defun olt-set-outline-old (&optional buffer operation from to undo-p)
"olt: アウトラインが最新状態でないことを表現する。"
(unless buffer
(setq buffer (selected-buffer)))
(when (and (buffer-local-value buffer '*olt-buffer-latest*) (treeview-open-p))
(save-excursion
(unless (eq (selected-buffer) buffer)
(set-buffer buffer))
(setq *olt-buffer-latest* nil))
(let ((root-hitem (gethash buffer *olt-buffer-hash*))
(hitem (treeview-get-selected-item)))
(when (treeview-hitem-valid-p root-hitem)
(treeview-set-item-text root-hitem (concat "* " (buffer-name buffer)))
(while (and (treeview-hitem-valid-p hitem)
(not (eq (nth 0 (gethash hitem *olt-hash*)) :buffer-node)))
(setq hitem (treeview-get-parent-item hitem)))
(when (eql root-hitem hitem)
(setq hitem (treeview-get-selected-item))
(while (and (treeview-hitem-valid-p hitem)
(not (eq (nth 0 (gethash hitem *olt-hash*)) :buffer-node)))
(when (member (nth 0 (gethash hitem *olt-hash*))
'(:node :header-node :dependent-node))
(treeview-set-item-icon hitem *olt-update-item-icon* *olt-selected-item-icon*))
(setq hitem (treeview-get-parent-item hitem))))
))
(olt-treeview-modify-color t)))
(defun olt-get-ranges (&optional (hitem (treeview-get-selected-item)))
(when (and (treeview-open-p)
(treeview-hitem-valid-p hitem))
(let (value wide-range narrow-range view-range restriction-range emphasis-range)
(setq value (gethash hitem *olt-hash*))
(when (find (car value) '(:node :header-node :dependent-node :dummy-node :info-node))
(setq wide-range (nth 2 value))
(setq narrow-range (nth 3 value))
(setq title-range (nth 4 value))
(if (and *olt-range-type-narrow* narrow-range)
(setq view-range narrow-range)
(setq view-range wide-range))
(when *olt-view-restriction*
(if (and (numberp (cdr view-range))
(< (car view-range) (cdr view-range))
(save-excursion
(goto-char (cdr view-range))
(and (bolp) (not (eobp)))))
(setq restriction-range (cons (car view-range) (1- (cdr view-range))))
(setq restriction-range view-range)))
(when *olt-view-emphasis*
(if restriction-range
(setq emphasis-range title-range)
(setq emphasis-range view-range)))
(values view-range restriction-range emphasis-range wide-range narrow-range title-range)))))
(defun olt-get-parent-buffer-node (&optional (hitem (treeview-get-selected-item)))
(let (value)
(setq value (gethash hitem *olt-hash*))
(while (and value (not (eq (car value) :buffer-node)))
(setq hitem (treeview-get-parent-item hitem))
(setq value (gethash hitem *olt-hash*)))
(if (eq (car value) :buffer-node)
(values hitem value)
nil)))
(defun olt-get-action-immediately (&optional (hitem (treeview-get-selected-item)))
"バッファの設定が即ノード実行であるか"
(let ((buffer (olt-get-node-related-buffer hitem)))
(cond ((eq buffer (selected-buffer))
*olt-action-immediately*)
((bufferp buffer)
(save-excursion
(set-buffer buffer)
*olt-action-immediately*))
(t nil))))
(defun olt-unset-text-emphasis ()
(when *olt-view-emphasis*
(delete-text-attributes *olt-tag*)))
(defun olt-set-text-emphasis (range)
(olt-unset-text-emphasis)
(apply #'set-text-attribute
(append (list (car range) (cdr range) *olt-tag*)
*olt-emphasis-attribute*)))
(defun olt-sync-local-variables (sym &optional (local t))
(dolist (variables *olt-sync-local-variables-list*)
(when (find sym variables)
(if local
(dolist (variable variables)
(set variable (symbol-value variable)))
(dolist (variable variables)
(set-default variable (symbol-value variable))
(kill-local-variable variable))))))
(defun olt-local-variables-local-p (sym)
"グループ内のいずれかが local なら t"
(let (result)
(dolist (variables *olt-sync-local-variables-list*)
(when (find sym variables)
(dolist (variable variables)
(when (local-variable-p variable)
(setq result t)
(return)))
(return)))
result))
(defun olt-encode-escape-sequence (string)
(cond
((stringp string)
(dolist (ec *olt-escape-char-alist*)
(setq string (substitute-string string (car ec) (cdr ec))))
string)
(t nil)))
(defun olt-add-option-prop-page (ident tmpl init handlers result)
(setq *olt-option-prop-page* (delete ident *olt-option-prop-page* :test #'eq
:key #'(lambda (x) (if (consp x) (car x) nil))))
(setf (get ident 'olt-prop-result) result)
(push (list ident tmpl init handlers) *olt-option-prop-page*))
(defun olt-tool-bar-update-close ()
(or (treeview-open-p) :disable))
(defun olt-tool-bar-update-action-immediately ()
(cond ((not (treeview-open-p)) :disable)
(*olt-action-immediately* :check)))
(defun olt-tool-bar-update-range-type-narrow ()
(cond ((not (treeview-open-p)) :disable)
(*olt-range-type-narrow* :check)))
(defun olt-tool-bar-update-view-restriction ()
(cond ((not (treeview-open-p)) :disable)
(*olt-view-restriction* :check)))
(defun olt-tool-bar-update-view-emphasis ()
(cond ((not (treeview-open-p)) :disable)
(*olt-view-emphasis* :check)))
(defun olt-tool-bar-update-chase ()
(cond ((not (treeview-open-p)) :disable)
(*olt-chase-cursor* :check)))
(defun olt-tool-bar-update-restricted-region ()
(and hide-restricted-region :check))
(defun olt-tool-bar-update-opening-and-shutting ()
(cond ((not (treeview-open-p)) :disable)
((olt-shutting-p) :check)))
(defun olt-tool-bar ()
(create-tool-bar
'olt-tool-bar
(merge-pathnames "site-lisp/olt/olt-toolbar.bmp" (si:system-root))
'(("アウトライン作成(更新)" 0 olt-make)
("最大化" 8 olt-toggle-opening-and-shutting olt-tool-bar-update-opening-and-shutting)
("閉じる" 1 olt-close olt-tool-bar-update-close)
:sep
("即時ノード実行" 2 olt-toggle-action-immediately-tool-bar olt-tool-bar-update-action-immediately)
("カーソルに追従" 3 olt-toggle-chase-tool-bar olt-tool-bar-update-chase)
("範囲タイプ：狭" 4 olt-toggle-range-type-narrow-tool-bar olt-tool-bar-update-range-type-narrow)
("表示範囲制限" 5 olt-toggle-view-restriction-tool-bar olt-tool-bar-update-view-restriction)
("強調表示" 6 olt-toggle-view-emphasis-tool-bar olt-tool-bar-update-view-emphasis)
:sep
("制限範囲の隠蔽" 7 olt-toggle-hide-restricted-region olt-tool-bar-update-restricted-region)
)))
(defun olt-tool-bar ()
(create-tool-bar
'olt-tool-bar
(merge-pathnames "site-lisp/olt/olt-toolbar.bmp" (si:system-root))
'(("アウトライン作成(更新)" 0 olt-make)
("閉じる" 1 olt-close olt-tool-bar-update-close))))
(defun find-file-auto-olt-mode (string)
(let ((package (find-package "outline-tree"))
olt-mode)
(when (or (and (setq olt-mode (find-symbol (concat "olt-make-" string) package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-" (string-downcase string)) package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-" string "-mode") package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-" (string-downcase string) "-mode") package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-regexp-" string) package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-regexp-" (string-downcase string)) package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-regexp-" string "-mode") package))
(fboundp olt-mode))
(and (setq olt-mode (find-symbol (concat "olt-make-regexp-" (string-downcase string) "-mode") package))
(fboundp olt-mode)))
(setq *olt-make-function-auto-mode-parameter* olt-mode)
(setq *olt-make-function* olt-mode)
t)))
(defun olt-open ()
"outline-tree を開く"
(interactive)
(unless (treeview-open-p)
(unless (olt-config-loaded-p)
(olt-config-load)
(olt-update-olt-make-function-menu)
(olt-init-setting))
(cond
((find *olt-position* (list XPIS_LEFT XPIS_RIGHT))
(treeview-create-ex *olt-width* *olt-position*))
((find *olt-position* (list XPIS_TOP XPIS_BOTTOM))
(treeview-create-ex *olt-height* *olt-position*)))
(when *olt-add-treeview-window*
(case *olt-add-treeview-window*
(:fix (olt-enlarge-window nil))
(:enlarge (olt-enlarge-window t))
(t (olt-enlarge-window t))))
(clrhash *olt-hash*)
(clrhash *olt-buffer-hash*)
(add-hook '*delete-buffer-hook* 'olt-delete)
(add-hook '*pre-command-hook* 'olt-unset-text-emphasis)
(add-hook '*post-command-hook* 'olt-select-cursor-related-node-for-hook)
(add-hook 'ed::*after-save-buffer-hook* 'olt-update-buffer-node-title)
(add-hook 'post-buffer-modified-hook 'olt-set-outline-old)
(add-hook '*kill-xyzzy-hook* 'olt-close)
(treeview-disable-char-jump t)
(treeview-click-callback
#'(lambda (hitem)
(when (olt-get-action-immediately hitem)
(stop-timer 'olt-node-action)
(start-timer 0.01 'olt-node-action t))))
(treeview-dblclk-callback
#'(lambda (hitem)
(unless (olt-get-action-immediately hitem)
(stop-timer 'olt-node-action)
(start-timer 0.01 'olt-node-action t))))
(let (keymap key x key-str)
(treeview-keydown-callback
#'(lambda (hitem vkey flag)
(unless (keymapp keymap)
(setq keymap *olt-map*)
(setq key-str ""))
(setq key (win-user:vkey-to-key vkey))
(setq x (lookup-keymap *olt-fix-map* key))
(if x
(progn
(setq keymap nil)
(setq key-str "")
(olt-message "[fix] ~A" (key-to-string key))
(when (and (fboundp x) (commandp x))
(setq ed::*last-command* ed::*this-command*)
(setq ed::*this-command* x)
(call-interactively x)
(run-hooks 'ed::*post-command-hook*)))
(progn
(setq x (lookup-keymap keymap key))
(if (keymapp x)
(progn
(if (string= key-str "")
(setq key-str (key-to-string key))
(setq key-str (concat key-str " " (key-to-string key))))
(olt-message "~A-" key-str)
(setq keymap x))
(progn
(if (string/= key-str "")
(progn
(setq key-str (concat key-str " " (key-to-string key)))
(olt-message "~A" key-str))
(message " "))
(setq keymap nil)
(when (and (fboundp x) (commandp x))
(setq ed::*last-command* ed::*this-command*)
(setq ed::*this-command* x)
(call-interactively x)
(run-hooks 'ed::*post-command-hook*)))))))))
(olt-focus-editor)
(olt-treeview-modify-style)
(run-hooks '*olt-open-hook*)))
(defun olt-close ()
"outline-tree を閉じる"
(interactive)
(widen)
(maphash #'(lambda (buffer hitem)
(if (and (not (deleted-buffer-p buffer))
(gethash buffer *olt-buffer-hash*))
(olt-delete buffer)))
*olt-buffer-hash*)
(when *olt-add-treeview-window*
(case *olt-add-treeview-window*
(:fix (olt-shrink-window nil))
(:enlarge (olt-shrink-window t))
(t (olt-shrink-window t))))
(when (and *olt-save-size*
(not (olt-shutting-p)))
(cond
((find (treeview-get-position) (list XPIS_LEFT XPIS_RIGHT))
(setq *olt-width* (olt-get-window-width (treeview-get-hwnd))))
((find (treeview-get-position) (list XPIS_TOP XPIS_BOTTOM))
(setq *olt-height* (olt-get-window-height (treeview-get-hwnd))))))
(treeview-close)
(delete-hook '*delete-buffer-hook* 'olt-delete)
(delete-hook '*pre-command-hook* 'olt-unset-text-emphasis)
(delete-hook '*post-command-hook* 'olt-select-cursor-related-node-for-hook)
(delete-hook 'ed::*after-save-buffer-hook* 'olt-update-buffer-node-title)
(delete-hook 'post-buffer-modified-hook 'olt-set-outline-old)
(delete-hook '*kill-xyzzy-hook* 'olt-close)
(olt-focus-editor)
(refresh-screen)
(run-hooks '*olt-close-hook*))
(defun olt-delete (&optional (buffer (selected-buffer)))
"エディタ部のバッファに対応するノードを削除"
(interactive)
(let ((hitem (gethash buffer *olt-buffer-hash*)))
(when (and (treeview-open-p)
(treeview-hitem-valid-p hitem))
(treeview-delete-item hitem)
(remhash buffer *olt-buffer-hash*)))
(save-excursion
(set-buffer buffer)
(run-hooks '*olt-delete-hook*))
(when (and *olt-close-unnecessary-treeview*
(zerop (treeview-get-count)))
(olt-set-outline-old)
(olt-close))
t)
(defun olt-shutting ()
(interactive)
(when (treeview-open-p)
(cond
((find (treeview-get-position) (list XPIS_LEFT XPIS_RIGHT))
(setq window-size (olt-get-window-width (treeview-get-hwnd))))
((find (treeview-get-position) (list XPIS_TOP XPIS_BOTTOM))
(setq window-size (olt-get-window-height (treeview-get-hwnd)))))
(treeview-setsize *olt-window-size-min* *olt-window-size-min* 10000 1)
(run-hooks '*olt-shutting-hook*)))
(defun olt-opening ()
(interactive)
(when (treeview-open-p)
(treeview-setsize
(if (<= *olt-window-size-threshold* window-size)
window-size *olt-window-size-default*)
*olt-window-size-min* 10000 1)
(run-hooks '*olt-opening-hook*)))
(defun olt-toggle-opening-and-shutting ()
(interactive)
(when (treeview-open-p)
(if (olt-shutting-p)
(olt-opening) (olt-shutting))))
(defun olt-make (&optional buffer following) (interactive)
(unless buffer
(setq buffer (selected-buffer)))
(if (listp buffer)
(dolist (x buffer)
(olt-make x following))
(save-excursion
(unless (eq buffer (selected-buffer))
(set-buffer buffer))
(olt-open)
(save-excursion
(save-restriction
(widen)
(if following
(narrow-to-region (progn (goto-bol) (point)) (point-max)))
(let ((root-hitem (gethash (selected-buffer) *olt-buffer-hash*)))
(if root-hitem
(progn
(while (not (eql 0 (treeview-item-has-children root-hitem)))
(treeview-delete-item (treeview-get-child-item root-hitem)))
(treeview-set-item-text root-hitem (buffer-name (selected-buffer)))
(if (get-buffer-file-name (selected-buffer))
(treeview-set-item-icon root-hitem *olt-file-icon* *olt-file-icon*)))
(progn
(setq root-hitem
(olt-insert-buffer-item (buffer-name (selected-buffer)) TVI_ROOT))
(if (get-buffer-file-name (selected-buffer))
(treeview-set-item-icon root-hitem *olt-file-icon* *olt-file-icon*))
(setf (gethash root-hitem *olt-hash*)
`(:buffer-node () ,(selected-buffer) ()))
(setf (gethash (selected-buffer) *olt-buffer-hash*) root-hitem)))
(when *olt-make-function-auto-mode-parameter*
(setq *olt-make-function* *olt-make-function-auto-mode-parameter*)
(setq *olt-make-function-auto-mode-parameter* nil))
(when (or (functionp *olt-make-function*)
(and (symbolp *olt-make-function*)
(fboundp *olt-make-function*)))
(long-operation
(funcall *olt-make-function* root-hitem)))
(treeview-expand-expand root-hitem :child t :visible nil
:depth (if (eq *olt-make-expand* :depth)
*olt-make-expand-depth*
*olt-make-expand*))
(olt-select-cursor-related-node nil)
(olt-focus-editor)
(refresh-screen))
(setq *olt-buffer-latest* t)
(enable-post-buffer-modified-hook t)))
(olt-treeview-modify-color)
(run-hooks '*olt-make-hook*))))
(defun olt-make-only-buffer-node (&optional buffer open-p)
"olt: buffer-node のみ作成
BUFFER には buffer または buffer の list を指定。
nil の場合は (selected-buffer) が対象となる。
olt-make とは異なり、treeview が開いていない場合は指定がない限り
olt-open を行わない。"
(interactive)
(unless (or open-p (treeview-open-p))
(return-from olt-make-only-buffer-node))
(let (r (*olt-make-function* nil))
(declare (special *olt-make-function*))
(unless buffer
(setq buffer (selected-buffer)))
(cond
((listp buffer)
(dolist (x buffer)
(olt-make-only-buffer-node x)))
((bufferp buffer)
(setq r (run-hook-with-args-until-success
'*before-olt-make-only-buffer-node-hook* buffer))
(when r (return-from olt-make-only-buffer-node r))
(olt-make buffer)
(olt-set-outline-old buffer)))))
(defun olt-make-only-buffer-node-all-buffer ()
(interactive)
(olt-make-only-buffer-node (buffer-list)))
(defun olt-goto-node-related-point (&optional (hitem (treeview-get-selected-item))
&key (top nil))
(interactive)
(when (and (treeview-open-p)
(treeview-hitem-valid-p hitem))
(olt-set-buffer hitem)
(let ((po (point)))
(multiple-value-bind (view-range restriction-range emphasis-range)
(olt-get-ranges hitem)
(when (and view-range
(or top
(< po (car view-range))
(< (cdr view-range) po)))
(widen)
(goto-char (car view-range))
(cond
((and (eq *olt-recenter* :line)
(numberp *olt-recenter-line*)
(integerp *olt-recenter-line*))
(recenter *olt-recenter-line*))
(*olt-recenter*
(recenter))))))))
(defun olt-select-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(if (treeview-hitem-valid-p hitem)
(olt-select-node-1 hitem #'identity)))
(defun olt-select-child-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-child-item))
(defun olt-select-next-sibling-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-next-sibling-item))
(defun olt-select-prev-sibling-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-prev-sibling-item))
(defun olt-select-parent-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-parent-item))
(defun olt-select-first-visible-node ()
(interactive)
(olt-select-node-1 nil #'treeview-get-first-visible-item))
(defun olt-select-last-visible-node ()
(interactive)
(olt-select-node-1 nil #'treeview-get-last-visible-item))
(defun olt-select-last-window-visible-node ()
(interactive)
(olt-select-node-1 nil #'treeview-get-last-window-visible-item))
(defun olt-select-next-visible-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-next-visible-item))
(defun olt-select-prev-visible-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-prev-visible-item))
(defun olt-select-ancestor-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-ancestor-item))
(defun olt-select-descendants-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-descendants-item))
(defun olt-select-up-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-up-item))
(defun olt-select-down-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-down-item))
(defun olt-select-youngest-child-node (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-youngest-child-item))
(defun olt-select-root-node ()
(interactive)
(olt-select-node-1 nil #'treeview-get-root-item))
(defun olt-select-bottom-node ()
(interactive)
(olt-select-node-1 nil #'treeview-get-bottom-item))
(defun olt-select-node-delay ()
(interactive)
(let* ((ohitem (treeview-get-selected-item))
(fn #'(lambda ()
(let ((hitem (treeview-get-selected-item)))
(when (treeview-hitem-valid-p hitem)
(treeview-select-item ohitem)
(olt-select-node-1 hitem #'identity))))))
(start-timer *olt-select-node-delay-sec* fn t)))
(defun olt-select-up-key-node-and-default-action (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-up-key-item))
(defun olt-select-down-key-node-and-default-action (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-down-key-item))
(defun olt-select-left-key-node-and-default-action (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-left-key-item)
(when (treeview-expand-p hitem)
(treeview-expand-collapse hitem)))
(defun olt-select-right-key-node-and-default-action (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-select-node-1 hitem #'treeview-get-right-key-item)
(when (and (not (zerop (treeview-item-has-children hitem)))
(not (treeview-expand-p hitem)))
(treeview-expand-expand hitem)))
(defun olt-select-buffer-related-buffer-node (&optional buffer)
"buffer に対応した buffer-node を選択。"
(interactive)
(olt-select-node (olt-get-buffer-related-buffer-node buffer)))
(defun olt-select-cursor-related-node (&optional (expand t))
"olt: ポイントの位置に対応したノードを選択。
EXPAND: t 可能な限り展開
<integer> 展開する階層レベル
上記以外 展開しない"
(interactive)
(let ((*olt-action-immediately* nil))
(declare (special *olt-action-immediately*))
(olt-select-node (olt-get-cursor-related-node expand))))
(defun olt-select-cursor-related-node-for-hook ()
(interactive)
(when (and *olt-chase-cursor*
(treeview-open-p)
(and (symbolp *this-command*)
(string/= (package-name (symbol-package *this-command*))
"outline-tree"))
(not (find *this-command* *olt-except-commands-for-select-cursor-related-node*)))
(olt-select-cursor-related-node (if (eq *olt-chase-expand* :depth)
*olt-chase-expand-depth*
*olt-chase-expand*))))
(defun olt-select-cursor-related-node-or-make (&optional buffer)
(interactive)
(unless buffer
(setq buffer (selected-buffer)))
(if (listp buffer)
(dolist (x buffer)
(olt-select-cursor-related-node-or-make x))
(when (and (bufferp buffer)
(not (deleted-buffer-p buffer)))
(save-excursion
(unless (eq buffer (selected-buffer))
(set-buffer buffer))
(if (and (treeview-open-p) *olt-buffer-latest*)
(olt-select-cursor-related-node)
(olt-make))))))
(defun olt-update-all-modified-buffer-node ()
(interactive)
(when (treeview-open-p)
(let ((buffer-list (olt-get-modified-buffer-list)))
(if buffer-list
(olt-make buffer-list)))))
(defun olt-update-buffer-node-title (&optional buffer)
(interactive)
(unless buffer
(setq buffer (selected-buffer)))
(cond
((listp buffer)
(dolist (x buffer)
(olt-update-buffer-node-title x)))
((bufferp buffer)
(let ((hitem (gethash buffer *olt-buffer-hash*)))
(when hitem
(treeview-set-item-text
hitem
(concat (if (buffer-local-value buffer '*olt-buffer-latest*) "" "* ")
(buffer-name buffer))))))))
(defun olt-node-action (&optional (hitem (treeview-get-selected-item)))
(interactive)
(let (value func)
(setq value (gethash hitem *olt-hash*))
(if (null value)
(return-from olt-node-action nil))
(setq func (nth 1 value))
(if func
(funcall func)
(case (car value)
(:buffer-node
(olt-set-buffer)
(widen)
(refresh-screen))
((:node :header-node :dependent-node)
(olt-goto-node-related-point hitem :top t)
(multiple-value-bind (view-range restriction-range emphasis-range)
(olt-get-ranges hitem)
(widen)
(when restriction-range
(narrow-to-region (car restriction-range) (cdr restriction-range)))
(when emphasis-range
(olt-set-text-emphasis emphasis-range)))
(refresh-screen))
((:info-node :dummy-node)
(olt-node-action (treeview-get-parent-item hitem)))))))
(defun olt-set-buffer (&optional (hitem (treeview-get-selected-item)))
(interactive)
(let ((buffer (olt-get-node-related-buffer hitem)) window)
(when (and (bufferp buffer)
(not (deleted-buffer-p buffer)))
(setq window (get-buffer-window buffer))
(if window
(set-window window)
(set-buffer buffer)))))
(defun olt-set-insert-mark (&optional (hitem (treeview-get-selected-item)) (after 1))
(interactive)
(treeview-set-insert-mark hitem))
(defun olt-edit-label (&optional (hitem (treeview-get-selected-item)))
(interactive)
(when (treeview-hitem-valid-p hitem)
(treeview-edit-label hitem)))
(defun olt-nop (&optional hitem)
(interactive)
nil)
(defun olt-expand-expand (&optional (hitem (treeview-get-selected-item))
&key sibling child)
(interactive)
(treeview-expand-expand hitem :sibling sibling :child child)
(treeview-ensure-visible (treeview-get-selected-item)))
(defun olt-expand-expand-child (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-expand hitem :child t))
(defun olt-expand-expand-sibling (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-expand hitem :sibling t))
(defun olt-expand-expand-sibling-child (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-expand hitem :sibling t :child t))
(defun olt-expand-expand-all ()
(interactive)
(olt-expand-expand TVGN_ROOT :sibling t :child t))
(defun olt-expand-collapse (&optional (hitem (treeview-get-selected-item))
&key sibling child)
(interactive)
(treeview-expand-collapse hitem :sibling sibling :child child)
(treeview-ensure-visible (treeview-get-selected-item)))
(defun olt-expand-collapse-child (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-collapse hitem :child t))
(defun olt-expand-collapse-sibling (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-collapse hitem :sibling t))
(defun olt-expand-collapse-sibling-child (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-collapse hitem :sibling t :child t))
(defun olt-expand-collapse-all ()
(interactive)
(olt-expand-collapse TVGN_ROOT :sibling t :child t))
(defun olt-expand-toggle (&optional (hitem (treeview-get-selected-item))
&key sibling child)
(interactive)
(treeview-expand-toggle hitem :sibling sibling :child child)
(treeview-ensure-visible (treeview-get-selected-item)))
(defun olt-expand-toggle-child (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-toggle hitem :child t))
(defun olt-expand-toggle-sibling (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-toggle hitem :sibling t))
(defun olt-expand-toggle-sibling-child (&optional (hitem (treeview-get-selected-item)))
(interactive)
(olt-expand-toggle hitem :sibling t :child t))
(defun olt-expand-toggle-all (&optional dummy-hitem)
(interactive)
(olt-expand-toggle TVGN_ROOT :sibling t :child t))
(defun olt-jump-node (pattern)
(interactive "sOLT: Node Jump: "
:default0 *treeview-last-search-string* :history0 'ed::search)
(long-operation
(when (interactive-p)
(setq *treeview-last-search-string* pattern))
(let (hitem hitems)
(unless pattern
(setq pattern (olt-get-jump-node-info)))
(when pattern
(setq hitems (treeview-find-nodes pattern))
(when (null hitems)
(olt-message "~Aが見つかりません" pattern)
(return-from olt-jump-node nil))
(if (= 1 (length hitems))
(setq hitem (car hitems))
(setq hitem (olt-select-nodes-dialog hitems)))
(if (treeview-hitem-valid-p hitem)
(olt-select-node hitem))))))
(defun olt-describe-key-briefly (key &optional arg)
(interactive
(list
(let (key one-key (keymap *olt-map*) x (key-str ""))
(loop
(olt-focus-editor)
(minibuffer-prompt "OLT: Describe key briefly: ~A" key-str)
(setq one-key (read-char *keyboard*))
(push one-key key)
(when (lookup-keymap *olt-fix-map* one-key)
(setq key (list one-key))
(return))
(setq x (lookup-keymap keymap one-key))
(if (keymapp x)
(progn
(setq key-str (concat key-str (key-to-string one-key) " "))
(setq keymap x))
(return)))
(minibuffer-message "")
(nreverse key))
nil))
(let (command)
(if (setq command (lookup-keymap *olt-fix-map* key))
(progn
(setq key (key-to-string key))
(cond
(arg
(save-excursion
(insert (format nil "OLT: [fix] ~a (~a)" key command))))
(t
(olt-message "[fix] ~a runs the command ~A" key command))))
(progn
(setq command (lookup-keymap *olt-map* key))
(setq key (key-to-string key))
(cond ((null command)
(olt-message "~a is not bound" key))
(arg
(save-excursion
(insert (format nil "OLT: ~a (~a)" key command))))
(t
(olt-message "~a runs the command ~A" key command)))))))
(defun olt-describe-bindings ()
(interactive)
(let ((shadow nil))
(long-operation
(olt-message "Building binding list...")
(with-output-to-temp-buffer ("*Help*")
(format t "Outline-Tree Fix Bindings:~%key~20Tbinding~%---~20T-------~%")
(ed::describe-bindings-1 "" *olt-fix-map* nil)
(push *olt-fix-map* shadow)
(format t "~%Outline-Tree Bindings:~%key~20Tbinding~%---~20T-------")
(ed::describe-bindings-1 "" *olt-map* shadow)
(format t "~%Outline-Tree I-search Bindings:~%key~20Tbinding~%---~20T-------")
(ed::describe-bindings-1 "" *treeview-isearch-map* nil)
(goto-char 0))
(olt-message "Building binding list...done"))))
(defun olt-other-window-on-treeview (&optional (arg 1 f) no-error)
(interactive "p")
(olt-other-window-on-editor arg no-error t))
(defun olt-move-previous-window-on-treeview (&optional (arg 1 f))
(interactive "p")
(olt-other-window-on-treeview (- arg) (null f)))
(defun olt-other-window-on-editor (&optional (arg 1 f) no-error outline-focus-p)
(interactive "p")
(let* ((first (car (caaddr (current-window-configuration))))
(last (caar (last (caddr (current-window-configuration)))))
(current (if outline-focus-p
(if (> arg 0) last first)
(selected-window)))
(target current)
(treeview-open-p (treeview-open-p))
(outline-focus-p outline-focus-p))
(if (> arg 0)
(dotimes (x arg)
(if (and treeview-open-p
(not outline-focus-p)
(eq target last))
(setq outline-focus-p t)
(progn
(setq outline-focus-p nil)
(setq target (next-window target))
(when (eq target current)
(olt-focus-editor)
(refresh-screen)
(and f (not no-error)
(error 'range-error :datum arg))
(return)))))
(dotimes (x (- arg))
(if (and treeview-open-p
(not outline-focus-p)
(eq target first))
(setq outline-focus-p t)
(progn
(setq outline-focus-p nil)
(setq target (previous-window target))
(when (eq target current)
(olt-focus-editor)
(refresh-screen)
(and f (not no-error)
(error 'range-error :datum arg))
(return))))))
(if outline-focus-p
(olt-focus-outline)
(progn
(olt-focus-editor)
(set-window target)
(refresh-screen)))))
(defun olt-move-previous-window-on-editor (&optional (arg 1 f))
(interactive "p")
(olt-other-window-on-editor (- arg) (null f)))
(defun olt-focus-editor ()
(interactive)
(winapi:SetFocus (get-window-handle))
(run-hooks '*olt-focus-editor-hook*))
(defun olt-focus-outline ()
(interactive)
(let (hitem)
(when (treeview-open-p)
(winapi:SetFocus (treeview-get-hwnd))
))
(run-hooks '*olt-focus-outline-hook*))
(defun olt-toggle-action-immediately (&key (arg nil sv) local)
(interactive)
(cond ((or local (local-variable-p '*olt-action-immediately*))
(setq *olt-action-immediately*
(if (null sv) (not *olt-action-immediately*) arg)))
(t
(setq-default *olt-action-immediately*
(if (null sv) (not *olt-action-immediately*) arg)))))
(defun olt-toggle-chase (&key (arg nil sv) local)
(interactive)
(cond ((or local (local-variable-p '*olt-chase-cursor*))
(setq *olt-chase-cursor*
(if (null sv) (not *olt-chase-cursor*) arg)))
(t
(setq-default *olt-chase-cursor*
(if (null sv) (not *olt-chase-cursor*) arg)))))
(defun olt-toggle-range-type-narrow (&key (arg nil sv) local)
(interactive)
(cond ((or local (local-variable-p '*olt-range-type-narrow*))
(setq *olt-range-type-narrow*
(if (null sv) (not *olt-range-type-narrow*) arg)))
(t
(setq-default *olt-range-type-narrow*
(if (null sv) (not *olt-range-type-narrow*) arg)))))
(defun olt-toggle-view-restriction (&key (arg nil sv) local)
(interactive)
(if *olt-view-restriction*
(widen))
(cond ((or local (local-variable-p '*olt-view-restriction*))
(setq *olt-view-restriction*
(if (null sv) (not *olt-view-restriction*) arg)))
(t
(setq-default *olt-view-restriction*
(if (null sv) (not *olt-view-restriction*) arg)))))
(defun olt-toggle-view-emphasis (&key (arg nil sv) local)
(interactive)
(if *olt-view-emphasis*
(olt-unset-text-emphasis))
(cond ((or local (local-variable-p '*olt-view-emphasis*))
(setq *olt-view-emphasis*
(if (null sv) (not *olt-view-emphasis*) arg)))
(t
(setq-default *olt-view-emphasis*
(if (null sv) (not *olt-view-emphasis*) arg)))))
(defun olt-toggle-hide-restricted-region (&key (arg nil sv) local)
(interactive)
(cond ((or local (local-variable-p 'hide-restricted-region))
(setq hide-restricted-region
(if (null sv) (not hide-restricted-region) arg)))
(t
(setq-default hide-restricted-region
(if (null sv) (not hide-restricted-region) arg)))))
(defun olt-option-property-sheet ()
(interactive)
(let (sheet result)
(dolist (page *olt-option-prop-page*)
(cond ((symbolp page)
(push page sheet))
(t
(push (list (car page)
(cadr page)
(let ((init (caddr page)))
(when init
(funcall init)))
(cadddr page))
sheet))))
(multiple-value-setq (result *olt-option-prop-page-no*)
(property-sheet sheet "ｱｳﾄﾗｲﾝﾂﾘｰ設定" *olt-option-prop-page-no*))
(dolist (r result)
(let ((f (get (car r) 'olt-prop-result)))
(when f
(funcall f (cdr r))))))
(olt-set-outline-old))
(defun olt-toggle-action-immediately-tool-bar ()
(interactive)
(olt-toggle-action-immediately :local *olt-tool-bar-local*))
(defun olt-toggle-chase-tool-bar ()
(interactive)
(olt-toggle-chase :local *olt-tool-bar-local*))
(defun olt-toggle-range-type-narrow-tool-bar ()
(interactive)
(olt-toggle-range-type-narrow :local *olt-tool-bar-local*))
(defun olt-toggle-view-restriction-tool-bar ()
(interactive)
(olt-toggle-view-restriction :local *olt-tool-bar-local*))
(defun olt-toggle-view-emphasis-tool-bar ()
(interactive)
(olt-toggle-view-emphasis :local *olt-tool-bar-local*))
(defun olt-tool-bar-change ()
(interactive)
(let ((visible-p (ed::command-bar-visible-p (ed::find-command-bar 'olt-tool-bar))))
(when visible-p
(hide-command-bar 'olt-tool-bar))
(delete-command-bar 'olt-tool-bar)
(gc)
(olt-message "outline-tree ツールバー更新中")
(sleep-for 0.2)
(defun olt-tool-bar ()
(create-tool-bar
'olt-tool-bar
(merge-pathnames "site-lisp/olt/olt-toolbar.bmp" (si:system-root))
'(("アウトライン作成(更新)" 0 olt-make)
("閉じる" 1 olt-close olt-tool-bar-update-close))))
(define-command-bar 'olt-tool-bar "Outline(&O)")
(when visible-p
(show-command-bar 'olt-tool-bar))
))
(defun olt-uninstall ()
(interactive)
(olt-close)
(run-hooks 'outline-tree::*olt-uninstall-hook*)
(delete-command-bar 'outline-tree::olt-tool-bar)
(let ((package (find-package "outline-tree")))
(dolist (x (copy-list ed::*history-variable-list*))
(if (eq (symbol-package x) package)
(unregister-history-variable x)))))