1;;; skk-foreword.el --- ����
2;; Copyright (C) 1997, 1998, 1999 Mikio Nakajima <minakaji@osaka.email.ne.jp>
3
4;; Author: Mikio Nakajima <minakaji@osaka.email.ne.jp>
5;; Maintainer: Hideki Sakurada <sakurada@kuis.kyoto-u.ac.jp>
6;;             Murata Shuuichirou  <mrt@astec.co.jp>
7;;             Mikio Nakajima <minakaji@osaka.email.ne.jp>
8;; Version: $Id: skk-foreword.el,v 1.1 2002/11/27 13:17:35 tatari Exp $
9;; Keywords: japanese
10;; Last Modified: $Date: 2002/11/27 13:17:35 $
11
12;; This file is not part of SKK yet.
13
14;; SKK is free software; you can redistribute it and/or modify
15;; it under the terms of the GNU General Public License as published by
16;; the Free Software Foundation; either versions 2, or (at your option)
17;; any later version.
18
19;; SKK is distributed in the hope that it will be useful
20;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
22;; GNU General Public License for more details.
23
24;; You should have received a copy of the GNU General Public License
25;; along with SKK, see the file COPYING.  If not, write to the Free
26;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston,
27;; MA 02111-1307, USA.
28
29;;; Commentary:
30
31;; ���Υե�����ϡ��桼�����ѿ���������Τ˻��Ѥ���ޥ���skk-*.el ��
32;; ���Ѥ���ޥ���ʤɡ��ѿ������������skk-*.el �κǽ��������Ƥ�����
33;; ����Фʤ�ʤ���Τ�ޤȤ᤿��ΤǤ����桼�����ѿ�����������ˡ���
34;; ���㤴����ȥ桼�����˶�̣���ʤ���Τ��¤�Ǥ����ΤǤϡ��桼������
35;; ���ɥ꡼�ǤϤʤ��ȹͤ��뤫��Ǥ���
36;;
37;;; Code:
38(require 'advice)
39
40;; necessary macro and functions to be declared before user variable declarations.
41
42;;;; macros
43;; Why I use non-intern temporary variable in the macro --- see comment in
44;; save-match-data of subr.el of GNU Emacs. And should we use the same manner
45;; in the save-current-buffer, with-temp-buffer and with-temp-file macro
46;; definition?
47(defmacro skk-save-point (&rest body)
48  (` (let ((skk-save-point (point-marker)))
49       (unwind-protect
50	   (progn (,@ body))
51	 (goto-char skk-save-point)
52         (skk-set-marker skk-save-point nil) ))))
53
54(defmacro skk-message (japanese english &rest arg)
55  ;; skk-japanese-message-and-error �� non-nil ���ä��� JAPANESE �� nil �Ǥ���
56  ;; �� ENGLISH ���������ꥢ��ɽ�����롣
57  ;; ARG �� message �ؿ����裲�����ʹߤΰ����Ȥ����Ϥ���롣
58  (append (list 'message (list 'if 'skk-japanese-message-and-error
59			       japanese english ))
60	  arg ))
61
62(defmacro skk-error (japanese english &rest arg)
63  ;; skk-japanese-message-and-error �� non-nil ���ä��� JAPANESE �� nil �Ǥ���
64  ;; �� ENGLISH ���������ꥢ��ɽ���������顼��ȯ�������롣
65  ;; ARG �� error �ؿ����裲�����ʹߤΰ����Ȥ����Ϥ���롣
66  (append (list 'error (list 'if 'skk-japanese-message-and-error
67			     japanese english ))
68	  arg ))
69
70(defmacro skk-yes-or-no-p (japanese english)
71  ;; skk-japanese-message-and-error �� non-nil �Ǥ���С�japanese �� nil �Ǥ�
72  ;; ��� english ��ץ��ץȤȤ��� yes-or-no-p ��¹Ԥ��롣
73  ;; yes-or-no-p �ΰ����Υץ��ץȤ�ʣ�����������Ǥ�����Ϥ��Υޥ�����
74  ;; ����ꥪ�ꥸ�ʥ�� yes-or-no-p ����Ѥ������������ɤ�ʣ���ˤʤ�ʤ���礬
75  ;; ���롣
76  (list 'yes-or-no-p (list 'if 'skk-japanese-message-and-error
77				   japanese english )))
78
79(defmacro skk-y-or-n-p (japanese english)
80  ;; skk-japanese-message-and-error �� non-nil �Ǥ���С�japanese �� nil �Ǥ�
81  ;; ��� english ��ץ��ץȤȤ��� y-or-n-p ��¹Ԥ��롣
82  (list 'y-or-n-p (list 'if 'skk-japanese-message-and-error
83				japanese english )))
84
85(defmacro skk-set-marker (marker position &optional buffer)
86  ;; �Хåե��������ͤǤ��� skk-henkan-start-point, skk-henkan-end-point,
87  ;; skk-kana-start-point, ���뤤�� skk-okurigana-start-point �� nil ���ä��顢
88  ;; �����ޡ��������ä��������롣
89  (list 'progn
90        (list 'if (list 'not marker)
91              (list 'setq marker (list 'make-marker)) )
92        (list 'set-marker marker position buffer) ))
93
94;; From viper-util.el.  Welcome!
95(defmacro skk-deflocalvar (var default-value &optional documentation)
96  (` (progn
97       (defvar (, var) (, default-value)
98	       (, (format "%s\n\(buffer local\)" documentation)))
99       (make-variable-buffer-local '(, var))
100     )))
101
102(defmacro skk-with-point-move (&rest form)
103  ;; �ݥ���Ȥ��ư���뤬�եå���¹Ԥ��Ƥۤ����ʤ����˻Ȥ���
104  (` (unwind-protect
105	 (progn (,@ form))
106       (setq skk-previous-point (point)) )))
107
108(defmacro skk-face-on (object start end face &optional priority)
109  (static-cond
110   ((eq skk-emacs-type 'xemacs)
111    (` (let ((inhibit-quit t))
112	 (if (not (extentp (, object)))
113	     (progn
114	       (setq (, object) (make-extent (, start) (, end)))
115	       (if (not (, priority))
116		   (set-extent-face (, object) (, face))
117		 (set-extent-properties
118		  (, object) (list 'face (, face) 'priority (, priority)) )))
119	   (set-extent-endpoints (, object) (, start) (, end))  ))))
120   (t
121    (` (let ((inhibit-quit t))
122	 (if (not (overlayp (, object)))
123	     (progn
124	       (setq (, object) (make-overlay (, start) (, end)))
125	       (and (, priority) (overlay-put (, object) 'priority (, priority)))
126	       (overlay-put (, object) 'face (, face)) )
127	   (move-overlay (, object) (, start) (, end)) ))))))
128
129(put 'skk-deflocalvar 'lisp-indent-function 'defun)
130
131;;;; inline functions
132(defun skk-file-exists-and-writable-p (file)
133  (and (setq file (expand-file-name file))
134       (file-exists-p file) (file-writable-p file) ))
135
136(defun skk-lower-case-p (char)
137  ;; CHAR ����ʸ���Υ���ե��٥åȤǤ���С�t ���֤���
138  (and (<= ?a char) (>= ?z char) ))
139
140(defun skk-downcase (char)
141  (or (cdr (assq char skk-downcase-alist)) (downcase char)) )
142
143(defun skk-mode-off ()
144  (setq skk-mode nil
145        skk-abbrev-mode nil
146        skk-latin-mode nil
147        skk-j-mode nil
148        skk-jisx0208-latin-mode nil
149        ;; j's sub mode.
150        skk-katakana nil )
151  ;; initialize
152  (setq skk-input-mode-string skk-hiragana-mode-string)
153  (force-mode-line-update)
154  (remove-hook 'pre-command-hook 'skk-pre-command 'local) )
155
156(defun skk-j-mode-on (&optional katakana)
157  (setq skk-mode t
158        skk-abbrev-mode nil
159        skk-latin-mode nil
160        skk-j-mode t
161        skk-jisx0208-latin-mode nil
162        ;; j's sub mode.
163        skk-katakana katakana )
164  ;; mode line
165  (setq skk-input-mode-string (if katakana skk-katakana-mode-string
166				skk-hiragana-mode-string ))
167  (force-mode-line-update) )
168
169(defun skk-latin-mode-on ()
170  (setq skk-mode t
171        skk-abbrev-mode nil
172        skk-latin-mode t
173        skk-j-mode nil
174        skk-jisx0208-latin-mode nil
175        ;; j's sub mode.
176        skk-katakana nil
177        skk-input-mode-string skk-latin-mode-string )
178  (force-mode-line-update) )
179
180(defun skk-jisx0208-latin-mode-on ()
181  (setq skk-mode t
182        skk-abbrev-mode nil
183        skk-latin-mode nil
184        skk-j-mode nil
185        skk-jisx0208-latin-mode t
186        ;; j's sub mode.
187        skk-katakana nil
188        skk-input-mode-string skk-jisx0208-latin-mode-string )
189  (force-mode-line-update) )
190
191(defun skk-abbrev-mode-on ()
192  (setq skk-mode t
193        skk-abbrev-mode t
194        skk-latin-mode nil
195        skk-j-mode nil
196        skk-jisx0208-latin-mode nil
197        ;; j's sub mode.
198        skk-katakana nil
199        skk-input-mode-string skk-abbrev-mode-string )
200  (force-mode-line-update) )
201
202(defun skk-in-minibuffer-p ()
203  ;; �����ȥХåե����ߥ˥Хåե����ɤ���������å����롣
204  (window-minibuffer-p (selected-window)) )
205
206(defun skk-insert-prefix (&optional char)
207  ;; skk-echo �� non-nil �Ǥ���Х����ȥХåե��� skk-prefix ���������롣
208  (and skk-echo
209       ;; skk-prefix ����������ɥ����оݤȤ��ʤ������������ץ�ե��å����ϡ�
210       ;; ����ʸ�������������������ƾõ��Τǡ����δ֡�buffer-undo-list ��
211       ;; t �ˤ��ƥ���ɥ�������ߤ��ʤ��Ȥ����꤬�ʤ���
212       (let ((buffer-undo-list t))
213         (insert (or char skk-prefix)) )))
214
215(defun skk-erase-prefix (&optional clean)
216  ;; skk-echo �� non-nil �Ǥ���Х����ȥХåե����������줿 skk-prefix ���
217  ;; �������ץ���ʥ������ CLEAN �����ꤵ���ȡ��ѿ��Ȥ��Ƥ� skk-prefix ��
218  ;; null ʸ���ˡ�skk-current-rule-tree �� nil ��������롣
219  ;;
220  ;; ����ʸ�������Ϥ��ޤ��������Ƥ��ʤ����ˤ��δؿ����ƤФ줿�Ȥ��ʤɤϡ��Х�
221  ;; �ե�����������Ƥ��� skk-prefix �Ϻ�������������ѿ��Ȥ��Ƥ� skk-prefix ��
222  ;; null ʸ���ˤ������ʤ���
223  (and skk-echo skk-kana-start-point
224       (not (string= skk-prefix ""))	; fail safe.
225       ;; skk-prefix �ξõ����ɥ����оݤȤ��ʤ���
226       (let ((buffer-undo-list t)
227	     (start (marker-position skk-kana-start-point)) )
228	 (and start
229	      (condition-case nil
230		  (delete-region start (+ start (length skk-prefix)))
231		(error
232		 (skk-set-marker skk-kana-start-point nil)
233		 (setq skk-prefix ""
234		       skk-current-rule-tree nil ))))))
235  (and clean (setq skk-prefix ""
236		   skk-current-rule-tree nil ))) ; fail safe
237
238(defun skk-string<= (str1 str2)
239  ;; STR1 �� STR2 �Ȥ���Ӥ��ơ�string< �� string= �Ǥ���С�t ���֤���
240  (or (string< str1 str2) (string= str1 str2)) )
241
242(defun skk-do-auto-fill ()
243  ;; auto-fill-function ���ͤ���������Ƥ���С�do-auto-fill �����뤹�롣
244  (and auto-fill-function (funcall auto-fill-function)) )
245
246;;;; from dabbrev.el.  Welcome!
247;; Ƚ��ְ㤤���Ȥ���礢�ꡣ�ײ��ɡ�
248(defun skk-minibuffer-origin ()
249  (nth 1 (buffer-list)) )
250
251(defun skk-current-insert-mode ()
252  (cond (skk-abbrev-mode 'abbrev)
253	(skk-latin-mode 'latin)
254	(skk-jisx0208-latin-mode 'jisx0208-latin)
255	(skk-katakana 'katakana)
256	(skk-j-mode 'hiragana) ))
257
258(defun skk-numeric-p ()
259  (and skk-use-numeric-conversion (require 'skk-num) skk-num-list) )
260
261(defun skk-substring-head-character (string)
262  (char-to-string (string-to-char string)) )
263
264(defun skk-get-current-candidate-simply (&optional noconv)
265  (if (> 0 skk-henkan-count)
266      (skk-error "�������Ф����Ȥ��Ǥ��ޤ���"
267		 "Cannot get current candidate" )
268    ;; (nth -1 '(A B C)) �ϡ�A ���֤��Τǡ���Ǥʤ����ɤ��������å����롣
269    (let ((word (nth skk-henkan-count skk-henkan-list)))
270      (and word
271	   (if (and (skk-numeric-p) (consp word))
272	       (if noconv (car word) (cdr word))
273	     word )))))
274
275;; convert skk-rom-kana-rule-list to skk-rule-tree.
276;; The rule tree follows the following syntax:
277;; <branch-list>    ::= nil | (<tree> . <branch-list>)
278;; <tree>         ::= (<char> <prefix> <nextstate> <kana> <branch-list>)
279;; <kana>         ::= (<�Ҥ餬��ʸ����> . <��������ʸ����>) | nil
280;; <char>         ::= <�Ѿ�ʸ��>
281;; <nextstate>    ::= <�Ѿ�ʸ��ʸ����> | nil
282
283;; �ĥ꡼�˥����������뤿��Υ������ե�����
284
285(defun skk-make-rule-tree (char prefix nextstate kana branch-list)
286  (list char
287	prefix
288	(if (string= nextstate "") nil nextstate)
289	kana
290	branch-list ))
291
292(defun skk-get-char (tree)
293  (car tree) )
294
295(defun skk-set-char (tree char)
296  (setcar tree char) )
297
298(defun skk-set-prefix (tree prefix)
299  (setcar (nthcdr 1 tree) prefix) )
300
301(defun skk-get-prefix (tree)
302  (nth 1 tree) )
303
304(defun skk-get-nextstate (tree)
305  (nth 2 tree) )
306
307(defun skk-set-nextstate (tree nextstate)
308  (if (string= nextstate "") (setq nextstate nil))
309  (setcar (nthcdr 2 tree) nextstate) )
310
311(defun skk-get-kana (tree)
312  (nth 3 tree) )
313
314(defun skk-set-kana (tree kana)
315  (setcar (nthcdr 3 tree) kana) )
316
317(defun skk-get-branch-list (tree)
318  (nth 4 tree) )
319
320(defun skk-set-branch-list (tree branch-list)
321  (setcar (nthcdr 4 tree) branch-list) )
322
323;; tree procedure for skk-kana-input.
324(defun skk-add-branch (tree branch)
325  (skk-set-branch-list tree (cons branch (skk-get-branch-list tree))) )
326
327(defun skk-select-branch (tree char)
328  (assq char (skk-get-branch-list tree)) )
329
330(defun skk-kana-cleanup (&optional force)
331  (let ((data (or
332	       (and skk-current-rule-tree
333		    (null (skk-get-nextstate skk-current-rule-tree))
334		    (skk-get-kana skk-current-rule-tree) )
335	       (and skk-kana-input-search-function
336		    (car (funcall skk-kana-input-search-function)) )))
337	kana )
338	(if (or force data)
339	    (progn
340	      (skk-erase-prefix 'clean)
341	      (setq kana (if (functionp data) (funcall data nil) data))
342	      (if (consp kana)
343		  (setq kana (if skk-katakana (car kana) (cdr kana))) )
344	      (if (stringp kana) (skk-insert-str kana))
345	      (skk-set-marker skk-kana-start-point nil)
346	      t ))))
347
348(defun skk-pre-command ()
349  (and (memq last-command '(skk-insert skk-previous-candidate))
350       (null (memq this-command skk-kana-cleanup-command-list))
351       (skk-kana-cleanup t) ))
352
353(defun skk-make-raw-arg (arg)
354  (cond ((= arg 1) nil)
355	((= arg -1) '-)
356	((numberp arg) (list arg)) ))
357
358(defun skk-unread-event (event)
359  ;; Unread single EVENT.
360  (setq unread-command-events (nconc unread-command-events (list event))) )
361
362(defun skk-after-point-move ()
363  (and (or (not skk-previous-point) (not (= skk-previous-point (point))))
364       (skk-get-prefix skk-current-rule-tree)
365       (skk-with-point-move (skk-erase-prefix 'clean)) ))
366
367(defun skk-get-last-henkan-data (key)
368  (cdr (assq key skk-last-henkan-data)) )
369
370(defun skk-put-last-henkan-data (key val)
371  (setq skk-last-henkan-data (put-alist key val skk-last-henkan-data)) )
372
373(defun skk-terminal-face-p ()
374  (and (not window-system)
375       ;;; XEmacs does not have this funciton...
376       (fboundp 'frame-face-alist) ; �ѿ�̾�ߤ����ʴؿ�����...��
377       (fboundp 'selected-frame) ))
378
379;;;; aliases
380;; for backward compatibility.
381;(define-obsolete-function-alias 'skk-zenkaku-mode 'skk-jisx0208-latin-mode)
382;(define-obsolete-function-alias 'skk-zenkaku-mode-on 'skk-jisx0208-latin-mode-on)
383;(define-obsolete-function-alias 'skk-zenkaku-insert 'skk-jisx0208-latin-insert)
384;(define-obsolete-function-alias 'skk-zenkaku-region 'skk-jisx0208-latin-region)
385;(define-obsolete-function-alias 'skk-zenkaku-henkan 'skk-jisx0208-latin-henkan)
386;(define-obsolete-function-alias 'skk-ascii-mode-on 'skk-latin-mode-on)
387;(define-obsolete-function-alias 'skk-ascii-mode 'skk-latin-mode)
388;(define-obsolete-function-alias 'skk-ascii-region 'skk-latin-region)
389;(define-obsolete-function-alias 'skk-ascii-henkan 'skk-latin-henkan)
390;(define-obsolete-function-alias 'skk-convert-ad-to-gengo 'skk-ad-to-gengo)
391;(define-obsolete-function-alias 'skk-convert-gengo-to-ad 'skk-gengo-to-ad)
392;(define-obsolete-function-alias 'skk-isearch-forward 'isearch-forward)
393;(define-obsolete-function-alias 'skk-isearch-forward-regexp 'isearch-forward-regexp)
394;(define-obsolete-function-alias 'skk-isearch-backward 'isearch-backward)
395;(define-obsolete-function-alias 'skk-isearch-backward-regexp 'isearch-backward-regexp)
396
397(defconst skk-background-mode
398  ;; from font-lock-make-faces of font-lock.el  Welcome!
399  'mono)
400
401;;;; version specific matter.
402;;; inline functions.
403(defun skk-str-length (str)
404    (length str))
405
406(defun skk-substring (str pos1 pos2)
407    (substring str pos1 pos2))
408
409;; no argument use only in SKK.
410(defun skk-read-event ()
411  (read-event))
412
413(defun skk-char-to-string (char)
414  (char-to-string char))
415
416(defun skk-ascii-char-p (char)
417  ;; CHAR �� ascii ʸ�����ä��� t ���֤���
418  (eq (char-charset char) 'ascii))
419
420(defun skk-str-ref (str pos)
421  (aref str pos))
422
423(defun skk-jisx0208-p (char)
424  (eq (char-charset char) 'japanese-jisx0208))
425
426(defun skk-char-octet (ch &optional n)
427  (char-octet ch n))
428
429;;; normal functions.
430;; tiny function, but called once in skk-kcode.el.  So not make it inline.
431;; or should I think to move to skk-kcode.el?
432(defun skk-make-char (charset n1 n2)
433  (make-char charset n1 n2))
434
435;; this one is called once in skk-kcode.el, too.
436(defun skk-charsetp (object)
437  (charsetp object))
438
439(defun skk-jisx0208-to-ascii (string)
440  (let ((char
441	 (get-char-code-property (string-to-char string) 'ascii) ))
442    (and char (char-to-string char)) ))
443
444(provide 'skk-foreword)
445;;; Local Variables:
446;;; End:
447;;; skk-forwords.el ends here
448