forked from kanchoku/tc
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathtc-complete.el
312 lines (276 loc) · 10.6 KB
/
tc-complete.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
;;; tc-complete.el --- completion with T-Code
;; Copyright (C) 2001 KITAJIMA Akira.
;; Author: KITAJIMA Akira <[email protected]>
;; Maintainer: KITAJIMA Akira
;; Keyword: completion
;; Created: Jul 31, 2001
;; $Id: tc-complete.el,v 1.17 2003/03/03 06:46:45 kitajima Exp $
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
;;; Code:
(require 'tc)
(defcustom tcode-complete-max-candidate-count 3
"*補完の際の最大候補数。"
:type 'integer :group 'tcode)
(defcustom tcode-complete-min-context-length 3
"*補完の際の文脈の最小長。"
:type 'integer :group 'tcode)
(defcustom tcode-complete-max-context-length 8
"*補完の際の文脈の最大長。"
:type 'integer :group 'tcode)
(defcustom tcode-complete-delay 0.5
"*候補が表示されるまでの待ち時間。"
:type 'float :group 'tcode)
(defcustom tcode-complete-dictionary-name "complete.dic"
"*補完辞書のファイル名。"
:type 'string :group 'tcode)
(defconst tcode-complete-buffer-name " *tcode: complete dictionary*")
;; 補完辞書のバッファ名
(defcustom tcode-complete-mazegaki-prefix-length 3
"*交ぜ書き変換辞書からの補完の場合に接頭辞とみなす文字数。"
:group 'tcode)
;;; 辞書の登録
(unless (assq tcode-complete-buffer-name tcode-dictionaries)
(setq tcode-dictionaries (cons (cons tcode-complete-buffer-name
tcode-complete-dictionary-name)
tcode-dictionaries)))
(defvar tcode-complete-candidate-list nil)
;; 補完候補を保持する変数
(make-variable-buffer-local 'tcode-complete-candidate-list)
(defvar tcode-message-overlay nil)
(make-variable-buffer-local 'tcode-message-overlay)
(defvar tcode-message-overlay-prefix ">")
(defvar tcode-message-overlay-suffix "<")
;;;
;;; オーバレイを用いたメッセージ表示
;;;
(defun tcode-overlay-message (str)
"overlayを用いて、現在の行にメッセージ(STR)を表示する。"
(save-excursion
(insert tcode-message-overlay-prefix))
(let ((point (point))
(nol (apply '+ (mapcar (lambda (c)
(if (= c ?\n)
1
0))
(string-to-list str)))))
(setq tcode-message-overlay
(if (overlayp tcode-message-overlay)
(move-overlay tcode-message-overlay (point) (1+ point))
(make-overlay point (1+ point))))
(overlay-put tcode-message-overlay
'after-string
(concat str tcode-message-overlay-suffix))
;; 表示すると隠れる場合は再表示
(if (>= (+ (count-lines (window-start) (point)) nol 1)
(1- (window-height)))
(recenter (1- (- nol))))))
(defun tcode-delete-overlay-message ()
"`tcode-overlay-message'で表示されたメッセージを消す。"
(interactive)
(when (overlayp tcode-message-overlay)
(save-excursion
(goto-char (overlay-start tcode-message-overlay))
(if (looking-at (regexp-quote tcode-message-overlay-prefix))
(delete-region (match-beginning 0) (match-end 0))))
(delete-overlay tcode-message-overlay)
(redraw-frame (selected-frame))))
;;;
;;; 辞書管理
;;;
;;;###autoload
(defun tcode-complete-reload-dictionary ()
"補完辞書を再読み込みする。"
(interactive)
(tcode-set-work-buffer tcode-complete-buffer-name
tcode-complete-dictionary-name
t))
(defun tcode-complete-lookup (prefix)
"補完用辞書からPREFIXを持つ候補を探す。"
(save-excursion
(tcode-set-work-buffer tcode-complete-buffer-name
tcode-complete-dictionary-name)
(goto-char (point-min))
(let ((prefix-regexp (concat "^" (regexp-quote prefix)))
candidate-list)
(catch 'overflow
(while (search-forward-regexp prefix-regexp nil t)
(beginning-of-line)
(let ((candidate (if (looking-at "^.+ \\(.+\\)$")
(buffer-substring (match-beginning 1)
(match-end 1))
(buffer-substring (point)
(progn (end-of-line) (point))))))
(unless (string= candidate prefix)
(setq candidate-list (cons candidate candidate-list))
(if (> (length candidate-list)
tcode-complete-max-candidate-count)
(throw 'overflow nil))))
(forward-line 1))
(reverse candidate-list)))))
(defun tcode-complete-switch-to-dictionary ()
"バッファを補完用辞書に切り替える。"
(interactive)
(switch-to-buffer
(tcode-set-work-buffer tcode-complete-buffer-name
tcode-complete-dictionary-name)))
(defun tcode-complete-add-to-dictionary (beg end)
"リージョンで指定した語を補完用辞書に登録する。"
(interactive "r")
(let ((str (buffer-substring beg end)))
(save-excursion
(tcode-set-work-buffer tcode-complete-buffer-name
tcode-complete-dictionary-name)
(goto-char (point-min))
(insert str "\n"))))
(defun tcode-complete-copy-entry-from-mazegaki-dictionary (prefix candidate)
(save-excursion
;; 補完辞書に登録済みかどうか調べる。
(tcode-set-work-buffer tcode-complete-buffer-name
tcode-complete-dictionary-name)
(goto-char (point-min))
(let* ((search-string (concat "\\(^\\| \\)" (regexp-quote candidate) "$"))
(found (catch 'found
(while (search-forward-regexp search-string nil t)
(save-excursion
(beginning-of-line)
(if (or (looking-at search-string)
(looking-at (regexp-quote prefix)))
(throw 'found t)))))))
(unless found
;; 補完辞書にはなかったので追加する。
;; 読みを交ぜ書き変換辞書から調べる。
(tcode-mazegaki-switch-to-dictionary)
(tcode-mazegaki-search-yomi (regexp-quote prefix))
(when (and (search-forward
(concat "/" (regexp-quote candidate) "/") nil t)
(save-excursion
(beginning-of-line)
(looking-at (regexp-quote prefix))))
;; 登録するべき候補を見つけた。
(beginning-of-line)
(looking-at (concat "\\(" prefix ".*\\) /"))
(let ((yomi (match-string 1)))
;; 読みyomi候補candidateで登録する。
(tcode-set-work-buffer tcode-complete-buffer-name
tcode-complete-dictionary-name)
(goto-char (point-min))
(insert (format "%s %s\n" yomi candidate))))))))
;;;
;;; 補完入力
;;;
;;;###autoload
(defun tcode-complete-insert (n)
"現在の文脈から推定できる入力候補を挿入する。
Nが指定された場合は、N番目の候補になる。"
(interactive "*p")
(when tcode-complete-candidate-list
(delete-region (car (car tcode-complete-candidate-list)) (point))
(let ((prefix (cdr (car tcode-complete-candidate-list)))
(candidate (nth (if (>= n 0)
(1- n)
(+ (length (cdr tcode-complete-candidate-list)) n))
(cdr tcode-complete-candidate-list))))
(tcode-complete-copy-entry-from-mazegaki-dictionary prefix candidate)
(tcode-insert candidate))
(tcode-complete-display)))
(global-set-key (kbd "M-RET") 'tcode-complete-insert)
;;;
;;; 補完候補抽出
;;;
(defun tcode-complete-scan-backward ()
"現在のポイントから文脈を得る。
文脈はリスト構造であり、リストの要素は(POINT . \"文字列\")である。
ここで、「文字列」は、POINTから始まる現在のポイントまでの文字列である。
文字列の長さは`tcode-complete-max-context-length'までである。"
(let ((raw-context (tcode-scan-backward tcode-complete-max-context-length))
context)
(while raw-context
(setq context (cons (cons (car (car raw-context))
(mapconcat 'cdr raw-context nil))
context)
raw-context (cdr raw-context)))
(reverse context)))
(defun tcode-complete-search-candidate (context)
"辞書から文脈に合う候補を探す。"
(catch 'found
(while context
(let ((candidate-list (append (tcode-complete-lookup (cdr (car context)))
(and (= tcode-complete-mazegaki-prefix-length
(length context))
(tcode-mazegaki-lookup-with-prefix
(string-to-list (cdr (car context)))))))
result)
(while candidate-list
(let ((candidate (car candidate-list)))
(setq result (nconc result (list candidate))
candidate-list (delete candidate candidate-list))))
(if result
(throw 'found (cons (car context) result))))
(setq context (cdr context)))))
(defun tcode-complete-make-candidate-list-string (prefix candidate-list)
"補完候補のリストを表す文字列を作る。"
(format "%s%s"
(let ((candidate (car candidate-list)))
(if (string= prefix
(substring candidate 0 (length prefix)))
(substring candidate (length prefix))
(concat "(" candidate ")")))
(let ((candidate-list (mapcar (lambda (candidate)
(substring candidate
(length prefix)))
(cdr candidate-list))))
(if candidate-list
(concat " ["
(let ((count 1))
(mapconcat (lambda (candidate)
(format "%d)%s"
(setq count (1+ count))
candidate))
(cdr candidate-list)
" "))
"]"))
"")))
(defun tcode-complete-display ()
"現在の文脈から推定できる入力候補を表示する。"
(interactive)
(let* ((candidates (tcode-complete-search-candidate
(tcode-complete-scan-backward)))
(real-candidate-list (cdr candidates))
(prefix (cdr (car candidates)))
(noc (length real-candidate-list)))
(if (or (> noc tcode-complete-max-candidate-count)
(< (length (string-to-list prefix))
tcode-complete-min-context-length))
(setq tcode-complete-candidate-list nil)
(setq tcode-complete-candidate-list candidates)
(when (and candidates
(not (window-minibuffer-p (selected-window))))
(unwind-protect
(progn
(tcode-overlay-message
(tcode-complete-make-candidate-list-string
prefix real-candidate-list))
(tcode-verbose-message (tcode-substitute-command-keys
"「\\[tcode-complete-insert]」で補完"))
(sit-for 5))
(tcode-delete-overlay-message))))))
(defun tcode-complete-display-function ()
(if (and (tcode-on-p)
(memq last-command tcode-input-command-list)
(sit-for tcode-complete-delay))
(tcode-complete-display)))
(add-hook 'post-command-hook 'tcode-complete-display-function)
(provide 'tc-complete)
;;; tc-complete.el ends here