forked from kanchoku/tc
-
Notifications
You must be signed in to change notification settings - Fork 0
/
tc-bushu.el
1195 lines (1106 loc) · 37.8 KB
/
tc-bushu.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
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; tc-bushu.el --- bushu conversion on T-Code
;; Copyright (C) 1996-2003 Kaoru Maeda, Yasushi Saito and Akira Kitajima.
;; Author: Kaoru Maeda <[email protected]>
;; Yasushi Saito <[email protected]>
;; Akira Kitajima <[email protected]>
;; YAGI Tatsuya <[email protected]>
;; Maintainer: Akira Kitajima
;; Created: 15 Sep 2001
;; Version: $Id: tc-bushu.el,v 2.51 2003/03/21 03:42:30 kitajima Exp $
;; Keywords: wp
;; 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-bushu-sequence-sensitive t
"* nilでない場合、部首の並べ方によって合成される文字の優先度が変わる。"
:type 'boolean :group 'tcode)
(defcustom tcode-bushu-prioritized-chars nil
"* 優先度が同じ場合に優先される文字のリスト。
文字列で指定する。"
:type 'string :group 'tcode)
(defvar tcode-bushu-inhibited-output-regexp
"^\\({.*}\\|[えしへアイウエオカクケサシタチテトニヌネノハヒホムメヨリルレロワン]\\)$")
(defvar tcode-bushu-reverse-dictionary-name "bushu.rev"
"逆引き部首合成辞書のファイル名")
(defconst tcode-bushu-reverse-buffer-name " *tcode: bushu reverse dictionary*")
(defvar tcode-bushu-expand-file-name "bushu.expand")
(defconst tcode-bushu-expand-buffer-name " *tcode: bushu expand*")
(defvar tcode-bushu-index2-file-name "bushu.index2")
(defconst tcode-bushu-index2-buffer-name " *tcode: bushu index2*")
(defvar tcode-bushu-help-dictionary-name "bushu.help"
"部首合成変換ヘルプ辞書のファイル名")
(defconst tcode-bushu-help-buffer-name " *tcode: bushu help dictionary*")
(defvar tcode-bushu-functions
'(tcode-bushu-compose-explicitly
tcode-bushu-complete-compose-set
tcode-bushu-complete-diff-set
tcode-bushu-strong-compose-set
tcode-bushu-strong-diff-set
tcode-bushu-weak-diff-set
tcode-bushu-weak-compose-set)
"* A list of functions to apply to characters for a character composition.")
(defvar tcode-bushu-list nil)
(defvar tcode-bushu-use-cache t)
;;;
;;; 部首合成変換ための基本データ操作
;;;
(defun tcode-bushu-search (str)
"現在のバッファ中の、 STR で始まる行のうち、最初のものを見つける。"
(let ((min (point-min))
(max (point-max))
kouho)
(or (catch 'found
(and (eobp)
(forward-line -1))
(while (< min max)
(cond ((string< (setq kouho
(buffer-substring (progn
(beginning-of-line)
(point))
(save-excursion
(end-of-line)
(point))))
str)
(forward-line 1)
(goto-char (ash (+ (setq min (point)) max) -1)))
((string< str kouho)
(goto-char (ash (+ min (setq max (point))) -1)))
((throw 'found t)))))
(progn
(beginning-of-line)
(looking-at (regexp-quote str))))))
;;; (defun tcode-bushu-parse-entry ()
;;; "現在の行を文字のリストとして返す。
;;; ポイントは行末に移動する。"
;;; (if (eobp)
;;; nil
;;; (string-to-list
;;; (buffer-substring (point)
;;; (progn (end-of-line) (point))))))
(defun tcode-bushu-b2s (x)
"漢字の構成部品(部首)を文字列に変換する。"
(if (stringp x) x (char-to-string x)))
(defun tcode-bushu-bl2s (l)
"漢字の構成部品(部首)のリストを文字列に変換する。"
(mapconcat 'tcode-bushu-b2s l nil))
(defun tcode-bushu-parse-entry ()
"現在の行を文字のリストとして返す。
ただし{}で囲まれた部分は文字列として返す。
ポイントは行末に移動する。"
(if (eobp)
nil
(let (ret)
(while (looking-at "\\([^{}\n]*\\)\\({[^{}\n]*}\\)")
(setq ret (nconc ret (string-to-list (match-string 1))
(list (match-string 2))))
(goto-char (match-end 0)))
(nconc ret (string-to-list (buffer-substring
(point) (progn (end-of-line) (point))))))))
(defun tcode-bushu-for-char (char)
"CHARを構成する部首のリストを返す。
CHARとして文字列も受け付ける。"
(let* ((str (tcode-bushu-b2s char))
(cache (get (intern-soft str tcode-stroke-table) 'bushu)))
(if (and cache
tcode-bushu-use-cache)
(copy-sequence cache)
(if (member char tcode-bushu-list)
(progn
(put (intern str tcode-stroke-table) 'bushu (list char))
(list char))
(with-current-buffer (get-buffer tcode-bushu-expand-buffer-name)
(if (tcode-bushu-search str)
(let ((bushu-list (cdr (tcode-bushu-parse-entry))))
(put (intern str tcode-stroke-table)
'bushu
bushu-list)
(copy-sequence bushu-list))
(put (intern str tcode-stroke-table) 'bushu (list char))
(list char)))))))
(defun tcode-bushu-lookup-index2-entry-internal (str)
(with-current-buffer (get-buffer tcode-bushu-index2-buffer-name)
(when (tcode-bushu-search (concat str " "))
(search-forward " ")
(tcode-bushu-parse-entry))))
(defun tcode-bushu-lookup-index2-entry-1 (char)
"CHARを部首として持つ文字のリストを返す。
返すリストにはCHARも含まれる。
CHARとして文字列も受け付ける。"
(cons char (tcode-bushu-lookup-index2-entry-internal (tcode-bushu-b2s char))))
(defun tcode-bushu-< (char1 char2)
"部首CHAR1とCHAR2の順序関係。
CHAR1, CHAR2として文字列も受け付ける。"
(if (stringp char1)
(if (stringp char2)
(string< char1 char2)
t)
(if (stringp char2)
nil
(< char1 char2))))
(defun tcode-bushu-lookup-index2-entry-2 (char char2)
"CHARとCHAR2を部首として持つ文字のリストを返す。
CHARとして文字列も受け付ける。"
(let ((str (if (tcode-bushu-< char char2)
(concat (tcode-bushu-b2s char) (tcode-bushu-b2s char2))
(concat (tcode-bushu-b2s char2) (tcode-bushu-b2s char)))))
(tcode-bushu-lookup-index2-entry-internal str)))
(defun tcode-bushu-lookup-index2-entry-many (char n)
"CHARをN個以上部首として持つ文字のリストを返す。"
(if (= n 1)
(tcode-bushu-lookup-index2-entry-1 char)
(tcode-bushu-lookup-index2-entry-internal
(if (stringp char)
(apply 'concat (make-list n char))
(make-string n char))
)))
(defun tcode-count (elt list)
"LIST中のELTの数を返す。"
(let ((n 0))
(while list
(if (equal elt (car list))
(setq n (1+ n)))
(setq list (cdr list)))
n))
(defun tcode-bushu-included-char-list (bushu &optional n)
"BUSHU を N 個以上含む文字のリストを返す。N省略時は N = 1 とみなす。"
(tcode-bushu-lookup-index2-entry-many bushu (or n 1)))
(defun tcode-bushu-included-set-p (list1 list2)
"LIST1がLIST2に含まれる集合かどうかを表す述語。
同じ要素が複数ある場合は、LIST2に含まれる数の方が少なければnilを返す。"
(let (x n (ret t))
(while list1
(setq x (car list1)
n (tcode-count x list1)
list1 (cdr list1))
(if (> n (tcode-count x list2))
(setq ret nil
list1 nil)))
ret))
(defun tcode-bushu-same-set-p (list1 list2)
"LIST1とLIST2が同じ集合かどうかを表す述語。
同じ要素が複数ある場合は、同じ数だけ含まれていないと等しいとはみなさない。"
(and (eq (length list1) (length list2))
(tcode-bushu-included-set-p list1 list2)))
(defun tcode-char-list-for-bushu (bushu-list)
"BUSHU-LISTで構成される字の集合を求める。"
;; 長さ2以下の場合を特別扱いする。
(cond ((null bushu-list) nil)
((null (cdr bushu-list))
(let* ((bushu (car bushu-list))
(included (tcode-bushu-included-char-list bushu))
(ret nil) l)
(while included
(setq l (tcode-bushu-for-char (car included)))
(if (and (equal bushu (car l))
(null (cdr l)))
(setq ret (cons (car included) ret)))
(setq included (cdr included)))
(nreverse ret)))
((null (nthcdr 2 bushu-list))
(let* ((bushu1 (car bushu-list))
(bushu2 (nth 1 bushu-list))
(included (tcode-bushu-lookup-index2-entry-2 bushu1 bushu2))
(ret nil) l)
(while included
(setq l (tcode-bushu-for-char (car included)))
(if (or (and (equal bushu1 (car l))
(equal bushu2 (nth 1 l))
(null (nthcdr 2 l)))
(and (equal bushu2 (car l))
(equal bushu1 (nth 1 l))
(null (nthcdr 2 l))))
(setq ret (cons (car included) ret)))
(setq included (cdr included)))
(nreverse ret)))
(t
(let* ((included (tcode-bushu-lookup-index2-entry-2
(car bushu-list) (nth 1 bushu-list)))
(ret nil) l)
(while included
(if (tcode-bushu-same-set-p (tcode-bushu-for-char (car included))
bushu-list)
(setq ret (cons (car included) ret)))
(setq included (cdr included)))
(nreverse ret)))))
(defun tcode-uniq (list)
(let* ((ret (copy-sequence list))
(l ret))
(while l
(setcdr l (delete (car l) (cdr l)))
(setq l (cdr l)))
ret))
;;;
;;; 部首合成変換用データの作成・ファイル操作
;;;
(defun tcode-bushu-add-to-index2 (char component)
(with-current-buffer (get-buffer tcode-bushu-index2-buffer-name)
(setq component (sort component 'tcode-bushu-<))
(let ((l nil) bushu)
(while component
(setq bushu (car component)
component (cdr component)
l (cons (list bushu) l))
(let ((tmp component) bushu2)
(while tmp
(setq bushu2 (car tmp)
tmp (cdr tmp)
l (cons (list bushu bushu2) l))
(when (equal bushu bushu2)
(let ((n 2))
(while (equal bushu (car tmp))
(setq n (1+ n)
component (cdr component)
tmp (cdr tmp)))
(if (> n 2)
(setq l (cons (make-list n bushu) l)))))
(while (equal bushu2 (car tmp))
(setq tmp (cdr tmp)))
))
(while (equal bushu (car component))
(setq component (cdr component)))
)
(while l
(if (tcode-bushu-search (concat (tcode-bushu-bl2s (car l)) " "))
(unless (member char (nthcdr 3 (tcode-bushu-parse-entry)))
(insert char))
(apply 'insert (car l))
(insert ?\ char ?\n))
(setq l (cdr l))))))
(defun tcode-bushu-make-index2 ()
(tcode-set-work-buffer tcode-bushu-expand-buffer-name
tcode-bushu-expand-file-name)
(let ((coding-system (and (boundp 'buffer-file-coding-system)
buffer-file-coding-system))
(noe (count-lines (point-min) (point-max)))
(count 0)
(percent -1))
(with-current-buffer (get-buffer-create tcode-bushu-index2-buffer-name)
(erase-buffer)
(or (not (boundp 'buffer-file-coding-system))
(set-buffer-file-coding-system coding-system)))
(goto-char (point-min))
(while (not (eobp))
(when (and tcode-verbose-message
(/= percent (setq percent (/ (* 100 count) noe))))
(message "部首合成辞書の拡張索引を作成中(%d%%)..." percent))
(let ((entry (tcode-bushu-parse-entry)))
(setq count (1+ count))
(if entry
(tcode-bushu-add-to-index2 (car entry) (cdr entry))))
(forward-line 1))
(tcode-save-buffer tcode-bushu-index2-buffer-name
tcode-bushu-index2-file-name t)
(when tcode-verbose-message
(message "部首合成辞書の拡張索引を作成中(100%%)...完了"))))
(defun tcode-bushu-expand-add-entry (char component)
(with-current-buffer (get-buffer tcode-bushu-expand-buffer-name)
(if (not (tcode-bushu-search (tcode-bushu-b2s char)))
(insert char (tcode-bushu-bl2s component) ?\n)
(end-of-line)
(insert (tcode-bushu-bl2s component)))))
(defun tcode-bushu-expand-char (char trace)
(if (member char tcode-bushu-list)
(list char)
(let ((str (tcode-bushu-b2s char)))
(with-current-buffer (get-buffer tcode-bushu-expand-buffer-name)
(tcode-bushu-search str)
(let ((entry (tcode-bushu-parse-entry)))
(if (and entry (equal char (car entry)))
;; すでに展開済み
(cdr entry)
;; 展開はまだ。
(set-buffer (get-buffer tcode-bushu-reverse-buffer-name))
(if trace
(tcode-bushu-search str)
(beginning-of-line))
(let ((entry (tcode-bushu-parse-entry)))
(if (and entry (cdr entry) (equal char (car entry)))
;; 展開できる
(let ((component
(apply 'nconc
(mapcar
(lambda (bushu)
(if (member bushu trace)
;; 循環している
(list ?⊥ bushu)
(tcode-bushu-expand-char
bushu
(cons bushu trace))))
(cdr entry)))))
(tcode-bushu-expand-add-entry char component)
component)
;; 展開できない = 部首
(setq tcode-bushu-list (cons char tcode-bushu-list))
(list char)))))))))
;;; obsolete
(defun tcode-bushu-expand-all ()
"各文字について、部首の集合を求める。"
(tcode-set-work-buffer tcode-bushu-reverse-buffer-name
tcode-bushu-reverse-dictionary-name
t)
(goto-char (point-min))
(while (search-forward-regexp "[ \t]*;.*$" nil t)
(delete-region (match-beginning 0) (match-end 0)))
(goto-char (point-min))
(while (search-forward-regexp "\n\n+" nil t)
(delete-region (1+ (match-beginning 0)) (match-end 0)))
(goto-char (point-min))
(while (search-forward-regexp "^\\([^{}\n]\\|{[^{}\n]*}\\)+\\([^{}\n]\\|{[^{}\n]*}\\)3" nil t)
(let ((str (match-string 2)))
(goto-char (match-beginning 2))
(delete-region (point) (match-end 2))
(insert str str str)))
(let ((bushu-expand-buf (get-buffer-create tcode-bushu-expand-buffer-name))
(coding-system (and (boundp 'buffer-file-coding-system)
buffer-file-coding-system))
(noe (count-lines (point-min) (point-max)))
(count 0))
(with-current-buffer bushu-expand-buf
(erase-buffer)
(or (not (boundp 'buffer-file-coding-system))
(set-buffer-file-coding-system coding-system)))
(goto-char (point-min))
(setq tcode-bushu-list nil)
(while (not (eobp))
(when tcode-verbose-message
(message "部首合成辞書を展開中(%d%%)..." (/ (* 100 count) noe)))
(let ((entry (tcode-bushu-parse-entry)))
(setq count (1+ count))
(if entry
(tcode-bushu-expand-char (car entry) nil)))
(forward-line 1))
(tcode-save-buffer tcode-bushu-expand-buffer-name
tcode-bushu-expand-file-name t)
(when tcode-verbose-message
(message "部首合成辞書を展開中(100%%)...完了"))))
(defun tcode-bushu-load-dictionary (&optional force)
"部首合成変換辞書を読み込む。
すでに読み込まれている場合は何もしない。
FORCEがnilでない場合は再読み込みする。"
(interactive "P")
(save-excursion
;; load dictionaries
(tcode-set-work-buffer tcode-bushu-expand-buffer-name
tcode-bushu-expand-file-name)
(if (file-newer-than-file-p (tcode-path-for-read
tcode-bushu-expand-file-name)
(tcode-path-for-read
tcode-bushu-index2-file-name))
(tcode-bushu-make-index2)
(tcode-set-work-buffer tcode-bushu-index2-buffer-name
tcode-bushu-index2-file-name))
;; make tcode-bushu-list
(unless tcode-bushu-list
(tcode-set-work-buffer tcode-bushu-index2-buffer-name
tcode-bushu-index2-file-name)
(goto-char (point-min))
(while (re-search-forward "^\\(.\\|{[^{}\n]*}\\) " nil t)
(beginning-of-line)
(let ((bushu (match-string 1)))
(setq tcode-bushu-list (cons bushu tcode-bushu-list))
(forward-line 1)))
(setq tcode-bushu-list (nreverse tcode-bushu-list)))))
;;; obsolete
(defun tcode-bushu-convert-dic-to-rev ()
"現在のバッファにあるdic形式部首合成辞書データをrev形式に変換する。"
(interactive)
(let ((buf (get-buffer-create "*tcode: dic to rev*")))
(with-current-buffer buf
(erase-buffer))
(goto-char (point-min))
(setq tcode-bushu-list nil)
(message "部首合成辞書を変換中...")
(while (not (eobp))
(let ((entry (tcode-bushu-parse-entry)))
(if entry
(save-excursion
(let ((str (mapconcat 'char-to-string
(list (car (cdr (cdr entry)))
(car entry)
(car (cdr entry)))
nil)))
(set-buffer buf)
(tcode-bushu-search str)
(insert str ?\n)))))
(forward-line 1))
(message "部首合成辞書を変換中...完了")
(pop-to-buffer buf)))
;;;
;;; 部首合成変換用基本演算
;;;
(defun tcode-delete-first-element (elt list)
"Delete first ELT in LIST with side effect."
(if list
(if (equal elt (car list))
(cdr list)
(let ((l list))
(catch 'found
(while l
(when (equal elt (car (cdr l)))
(setcdr l (cdr (cdr l)))
(throw 'found t))
(setq l (cdr l))))
list))))
(defun tcode-intersection (list1 list2)
"LIST1とLIST2との集合積を返す。
同じ要素が複数ある場合は区別する。
返り値における要素の並び方はLIST1の方に基づく。"
(let ((l2 (copy-sequence list2))
intersection)
(while (and list1 l2)
(let ((elt (car list1)))
(when (member elt l2)
(setq intersection (cons elt intersection)
l2 (tcode-delete-first-element elt l2)))
(setq list1 (cdr list1))))
(nreverse intersection)))
(defun tcode-complement-intersection (list1 list2)
(if list2
(let ((l1 (copy-sequence list1))
(l2 (copy-sequence list2))
ci)
(while (and l1 l2)
(let* ((e (car l1))
(c1 (tcode-count e l1))
(c2 (tcode-count e l2))
(diff (abs (- c1 c2))))
(if (> diff 0)
(setq ci (nconc ci (make-list diff e))))
(setq l1 (delete e l1)
l2 (delete e l2))))
(nconc ci l1 l2))
list1))
(defun tcode-subtract-set (list1 list2)
(if list2
(let ((l1 (copy-sequence list1))
(l2 (copy-sequence list2))
ci)
(while (and l1 l2)
(let* ((e (car l1))
(c1 (tcode-count e l1))
(c2 (tcode-count e l2))
(diff (- c1 c2)))
(if (> diff 0)
(setq ci (nconc ci (make-list diff e))))
(setq l1 (delq e l1)
l2 (delq e l2))))
(nconc l1 ci))
list1))
(defun tcode-bushu-superset (bushu-list)
"部首の部分集合がBUSHU-LISTである字の集合を求める。"
;; 長さ2以下の場合を特別扱いする。
(cond ((null bushu-list) nil) ;; ?
((null (cdr bushu-list))
(tcode-bushu-included-char-list (car bushu-list)))
((null (nthcdr 2 bushu-list))
(tcode-bushu-lookup-index2-entry-2 (car bushu-list)
(nth 1 bushu-list)))
(t
(let* ((bushu (car bushu-list))
(n (tcode-count bushu bushu-list))
(included
(if (> n 1)
(progn
(setq bushu-list (delete bushu bushu-list))
(tcode-bushu-included-char-list bushu n))
(setq bushu-list (cdr bushu-list))
(tcode-bushu-lookup-index2-entry-2
bushu (nth 1 bushu-list))))
(ret nil) l)
(while included
(if (tcode-bushu-included-set-p
bushu-list (tcode-bushu-for-char (car included)))
(setq ret (cons (car included) ret)))
(setq included (cdr included)))
(nreverse ret)))))
(defun tcode-bushu-higher-priority-p (bushu1 bushu2 ref default)
"REFを基準として、BUSHU1の方がBUSHU2よりも並び方が基準に近いかどうか。
判断できなかったり、する必要がない場合はDEFAULTを返す。"
(if tcode-bushu-sequence-sensitive
(catch 'done
(while (and ref bushu1 bushu2)
(let ((b1 (car bushu1))
(b2 (car bushu2))
(r (car ref)))
(cond ((and (equal r b1)
(not (equal r b2)))
(throw 'done t))
((and (not (equal r b1))
(equal r b2))
(throw 'done nil))
((and (not (equal r b1))
(not (equal r b2)))
(throw 'done default)))
(setq bushu1 (cdr bushu1)
bushu2 (cdr bushu2)
ref (cdr ref))))
default)
default))
(defun tcode-bushu-priority-level (char)
"CHARが変数`tcode-bushu-prioritized-chars'の何番目にあるかを返す。
なければ nil を返す。"
(if (and tcode-bushu-prioritized-chars
(not (stringp char)))
(let* ((priority-list
(string-to-list tcode-bushu-prioritized-chars))
(char-list (memq char priority-list)))
(if char-list
(- (length priority-list) (length char-list) -1)))))
(defun tcode-easier-stroke-p (s1 s2)
(if (= (length s1) (length s2))
;; とりあえず段だけ考慮。
;; ホームポジションや打ちやすさなど考慮するべき。
(let ((evfunc (lambda (a)
(let ((v (/ a 10)))
(if (>= v 3)
1
(ash v 1))))))
(> (apply '+ (mapcar evfunc s1))
(apply '+ (mapcar evfunc s2))))
(< (length s1) (length s2))))
(defvar bushu-list)
(defun tcode-bushu-less-p (char1 char2 &optional many)
"CHAR1がCHAR2より優先度が高いか?
自由変数BUSHU-LISTで指定された部首リストを基準とする。
MANYがnilの場合、同じ優先度では、BUSHU-LISTに含まれない
部首の数が少ない方が優先される。
nilでない場合は多い方が優先される。"
(let* ((bushu1 (tcode-bushu-for-char char1))
(bushu2 (tcode-bushu-for-char char2))
(i1 (tcode-intersection bushu1 bushu-list))
(i2 (tcode-intersection bushu2 bushu-list))
(l1 (- (length bushu1) (length i1)))
(l2 (- (length bushu2) (length i2))))
(if (= (length i1) (length i2))
(if (= l1 l2)
(let ((p1 (tcode-bushu-priority-level char1))
(p2 (tcode-bushu-priority-level char2)))
(cond (p1
(if p2
(< p1 p2)
t))
(p2
nil)
(t
(let ((val (tcode-bushu-higher-priority-p
i1 i2 (tcode-intersection
bushu-list (nconc bushu1 bushu2))
'default)))
(if (not (eq val 'default))
val
(let ((s1 (if (stringp char1)
nil
(tcode-encode char1)))
(s2 (if (stringp char2)
nil
(tcode-encode char2))))
(cond ((and s1 s2)
(tcode-easier-stroke-p s1 s2))
(s1
t)
(s2
nil)
(t
(tcode-bushu-< char1 char2)))))))))
(if many
(> l1 l2)
(< l1 l2)))
(> (length i1) (length i2)))))
(defun tcode-bushu-complete-compose-set (char-list)
(let ((bushu-list (apply 'nconc (mapcar 'tcode-bushu-for-char char-list))))
(sort (tcode-subtract-set (tcode-char-list-for-bushu bushu-list)
char-list)
'tcode-bushu-less-against-seqence-p)))
(defun tcode-bushu-strong-compose-set (char-list)
(let* ((bushu-list (apply 'nconc (mapcar 'tcode-bushu-for-char char-list)))
(r (tcode-bushu-superset bushu-list)))
(catch 'not-found
(mapcar (lambda (c)
(unless (setq r (delete c r))
(throw 'not-found nil)))
char-list)
(sort r 'tcode-bushu-less-p))))
(defun tcode-bushu-less-against-seqence-p (char1 char2)
(let ((p1 (tcode-bushu-priority-level char1))
(p2 (tcode-bushu-priority-level char2)))
(cond (p1
(if p2
(< p1 p2)
t))
(p2
nil)
(t
(tcode-bushu-higher-priority-p (tcode-bushu-for-char char1)
(tcode-bushu-for-char char2)
bushu-list
(tcode-bushu-< char1 char2))))))
(defun tcode-bushu-include-all-chars-bushu-p (char char-list)
(let* ((bushu (tcode-bushu-for-char char))
(new-bushu bushu))
(mapcar (lambda (char)
(setq new-bushu
(tcode-subtract-set new-bushu
(tcode-bushu-for-char char))))
char-list)
(setq bushu (tcode-subtract-set bushu new-bushu))
(catch 'false
(mapcar (lambda (char)
(or (tcode-subtract-set
bushu
(apply 'nconc
(mapcar
'tcode-bushu-for-char
(tcode-subtract-set char-list (list char)))))
(throw 'false nil)))
char-list)
t)))
(defun tcode-bushu-all-compose-set (char-list &optional bushu-list)
(let* ((char (car char-list))
(rest (cdr char-list))
(all-list
(tcode-uniq
(delete char
(apply 'nconc
(mapcar
(if rest
(lambda (bushu)
(tcode-bushu-all-compose-set rest
(cons bushu
bushu-list)))
(lambda (bushu)
(tcode-bushu-superset (cons bushu bushu-list))))
(tcode-bushu-for-char char)))))))
(delq nil
(mapcar (lambda (char)
(if (tcode-bushu-include-all-chars-bushu-p char char-list)
char))
all-list))))
(defun tcode-bushu-weak-compose-set (char-list)
(when (cdr char-list) ;; char-list が一文字だけの時は何もしない
(let ((bushu-list (apply 'nconc (mapcar 'tcode-bushu-for-char char-list))))
(sort (tcode-subtract-set (tcode-bushu-all-compose-set char-list)
(tcode-bushu-strong-compose-set char-list))
'tcode-bushu-less-p))))
(defun tcode-bushu-subset (bushu-list)
(delq nil
(mapcar
(lambda (char)
(unless (tcode-subtract-set (tcode-bushu-for-char char) bushu-list)
char))
(tcode-uniq (apply 'nconc
(mapcar 'tcode-bushu-included-char-list
(tcode-uniq bushu-list)))))))
(defun tcode-bushu-less-or-many-p (char1 char2)
(tcode-bushu-less-p char1 char2 t))
(defun tcode-bushu-strong-diff-set (char-list &optional bushu-list complete)
(let* ((char (car char-list))
(rest (cdr char-list))
(bushu (tcode-bushu-for-char char))
(i (if bushu-list
(tcode-intersection bushu bushu-list)
bushu)))
(if i
(let ((d1 (tcode-complement-intersection bushu i))
(d2 (tcode-complement-intersection bushu-list i)))
(if (or (and d1 d2)
(and (null d1)
(null d2)))
nil
(if rest
(delete char
(tcode-bushu-strong-diff-set rest (or d1 d2) complete))
(sort (delete char (if complete
(tcode-char-list-for-bushu (or d1 d2))
(tcode-bushu-subset (or d1 d2))))
'tcode-bushu-less-or-many-p))))
nil)))
(defun tcode-bushu-complete-diff-set (char-list)
(tcode-bushu-strong-diff-set char-list nil t))
(defun tcode-bushu-all-diff-set (char-list &optional bushu-list common-list)
(let* ((char (car char-list))
(rest (cdr char-list))
(bushu (tcode-bushu-for-char char))
(new-common-list (if common-list
(tcode-intersection bushu common-list)
bushu)))
(if new-common-list
(let* ((new-bushu-list
(if common-list
(nconc bushu-list
(tcode-complement-intersection bushu
new-common-list)
(tcode-complement-intersection common-list
new-common-list)))))
(if rest
(delete char (tcode-bushu-all-diff-set rest
new-bushu-list
new-common-list))
(tcode-uniq
(delete char (apply 'nconc
(mapcar
(lambda (bushu)
(let ((cl (copy-sequence new-common-list)))
(tcode-bushu-subset
(append new-bushu-list
(delete bushu cl)))))
new-common-list))))))
nil)))
(defun tcode-bushu-weak-diff-set (char-list)
(let* ((bushu-list (tcode-bushu-for-char (car char-list)))
(diff-set (tcode-subtract-set
(tcode-bushu-all-diff-set char-list)
(tcode-bushu-strong-diff-set char-list)))
(true-diff-set
(delq nil
(mapcar
(lambda (char)
(if (tcode-subtract-set (tcode-bushu-for-char char)
bushu-list)
nil
char))
diff-set))))
(tcode-uniq (nconc (sort true-diff-set 'tcode-bushu-less-or-many-p)
(sort (tcode-subtract-set diff-set true-diff-set)
'tcode-bushu-less-or-many-p)))))
(defun tcode-bushu-common-set (char-list)
(let ((bushu-list (tcode-bushu-for-char (car char-list))))
(catch 'not-found
(mapcar
(lambda (c)
(unless (setq bushu-list
(tcode-intersection bushu-list
(tcode-bushu-for-char c)))
(throw 'not-found nil)))
(cdr char-list))
(let ((kouho (tcode-bushu-subset bushu-list)))
(mapcar (lambda (c)
(if (memq c kouho)
(setq kouho (delq c kouho))))
char-list)
(sort kouho 'tcode-bushu-less-or-many-p)))))
(defun tcode-bushu-compose-explicitly (char-list)
(if (or (cdr (cdr char-list))
(null (nth 1 char-list))
(stringp (car char-list))
(stringp (nth 1 char-list)))
;; only for 2-char composition
nil
(save-excursion
(tcode-set-work-buffer tcode-bushu-help-buffer-name
tcode-bushu-help-dictionary-name
nil t)
(goto-char (point-min))
(if (let* ((case-fold-search nil)
(c1 (regexp-quote (char-to-string (car char-list))))
(c2 (regexp-quote (char-to-string (nth 1 char-list))))
(reg (concat "\\(^.\\| \\)\\("
c1 c2 "\\*?\\|" c2 c1
"\\*\\)\\( \\|$\\)")))
(re-search-forward reg nil t))
(progn
(beginning-of-line)
(list (tcode-following-char)))))))
;;;
;;; 部首合成変換用インタフェース
;;;
;;;###autoload
(defun tcode-bushu-compose-two-chars (char1 char2)
"CHAR1とCHAR2を合成する。"
(tcode-bushu-load-dictionary)
(let* ((str (concat (char-to-string char1)
(char-to-string char2)))
(cache (get (intern-soft str tcode-stroke-table) 'compose)))
(or (and tcode-bushu-use-cache
cache)
(let ((selected-char (tcode-bushu-compose (list char1 char2))))
(when selected-char
(put (intern str tcode-stroke-table) 'compose selected-char)
selected-char)))))
(defun tcode-bushu-funcall (func char-list)
(let ((r (funcall func char-list)))
(if tcode-bushu-inhibited-output-regexp
(delq nil (mapcar (lambda (x)
(if (string-match
tcode-bushu-inhibited-output-regexp
(tcode-bushu-b2s x))
nil
x))
r))
r)))
(defun tcode-bushu-compose (char-list)
"Compose a character from characters in CHAR-LIST.
See also `tcode-bushu-functions'."
(catch 'found
(mapcar
(lambda (function)
(let ((r (tcode-bushu-funcall function char-list)))
(if r
(throw 'found (car r)))))
tcode-bushu-functions)
nil))
(defun tcode-bushu-compose-interactively (char-list)
"CHAR-LISTをもとに対話的に合成する。"
(tcode-bushu-load-dictionary)
(let ((kouho-list (apply 'nconc (mapcar (lambda (function)
(tcode-bushu-funcall
function char-list))
tcode-bushu-functions))))
(if kouho-list
(tcode-bushu-select (tcode-uniq kouho-list) char-list)
(ding))))
(defun tcode-bushu-scan-backward (max)
"現 point より先頭方向にある日本語列または英単語一つのリストを返す。
リストの要素は(POINT . \"文字列\")である。
`tcode-scan-backward' と違い、英文字でも一文字の文字列で返す。
リストの順番としては、バッファの先頭に近い文字列が先頭の側になる。
リストの長さは最大 MAX 文字である。"
(save-excursion
(let (ch context)
(while (and (< (length context) max)
(tcode-skip-blank-backward)
(setq ch (tcode-preceding-char))
(not (bobp)))
(progn
(tcode-forward-char -1)
(setq context (cons (cons (point) (char-to-string ch))
context))))
context)))
(defun tcode-bushu-convert-preceding-chars (&optional arg)
"ポイントの前の2文字を合成する。"
(interactive "*P")
(tcode-bushu-init 2)
(let ((context (tcode-bushu-scan-backward 2)))
(if (/= (length context) 2)
(ding)
(let* ((prev-char (tcode-2-to-1 (tcode-string-to-char
(cdr (car (cdr context))))))
(prev-prev-char (tcode-2-to-1 (tcode-string-to-char
(cdr (car context)))))
(kanji (if (or arg current-prefix-arg)
(progn
(setq prefix-arg nil
current-prefix-arg nil)
(tcode-bushu-compose-interactively
(list prev-prev-char prev-char)))
(tcode-bushu-compose-two-chars prev-prev-char
prev-char)))
(p2 (car (car context))))
(if kanji
(progn
(setq tcode-bushu-occurrence (1+ tcode-bushu-occurrence))
(unless (stringp kanji)
(setq kanji (char-to-string kanji)))
(delete-region p2 (point))
(tcode-insert kanji)
(and tcode-auto-help
(tcode-display-direct-stroke kanji)
(tcode-auto-remove-help-char))
(setq tcode-help-char kanji))
(ding))))))
(defun tcode-bushu-prompt (char-list kouho-list)
(let* ((1st-kouho (car kouho-list))
(rest-kouho (cdr kouho-list))
(msg (format "%s => %s"
(mapconcat 'char-to-string char-list nil)
(if (stringp 1st-kouho)
1st-kouho
(char-to-string 1st-kouho))))
(rest-kouho-str (mapconcat (lambda (e)
(if (stringp e)
e
(char-to-string e)))
rest-kouho
" "))
(w (- (window-width (minibuffer-window))
5 (string-width msg) (string-width rest-kouho-str))))