/
manued.el
2132 lines (1929 loc) · 73.4 KB
/
manued.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
;;; manued.el --- a minor mode of manued proofreading method.
;; Author: Hitoshi Yamauchi
;; Maintainer: Hitoshi Yamauchi
;; Created: 16 Jan 1998
;; Keywords: proofreading, docs
;; Contributors: Atusi Maeda
;; Stefan Monnier (0.9.1)
;; Mikio Nakajima (0.9.3)
;; Takao Kawamura (0.9.3)
;; This file is not part of GNU Emacs.
;; 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, 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.
;; For a full copy of the GNU General Public License
;; see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; A minor mode implementing manued proofreading method.
;;
;; Manued stands for MANUscripting EDitor.
;;
;; Original idea of manued:
;; Ikuo Takeuchi, ``Manuscripting Editing on E-mail,'' 39th
;; Programming Symposium, 1998, January, pp.61--68
;;
;; The original paper is written in Japanese,
;; 竹内郁雄, ``電子メールで原稿を修正する方法 --- Manuscript
;; Editing (Manued, 真鵺道)を目指して ---'', 第 39 回プログラミン
;; グシンポジウム, 1998, 1月, pp.61--68
;;
;;
;;------------------------------------------------------------
;; debug 用の message 出力
;;------------------------------------------------------------
;; delete at release
;;(setq debug-on-error t)
;;(defun dbg (mes) (print mes (get-buffer "manued-debug")))
;;
;;------------------------------------------------------------
;; constant values
;;------------------------------------------------------------
;;; Code:
(defconst manued-version-num "0.9.5-current"
"The version of manued.el.
真鵺道のバージョン")
(defconst manued-build-day "2002-8-12"
"The day of last change of manued.el.
真鵺道の最終更新日")
(defconst manued-formatted-buffer-name "*manued*"
"Buffer name of formatted manued text.
真鵺道の整形済みバッファ名")
;;------------------------------
;; What kind of emacs is this?
;;------------------------------
(defconst manued-xemacs-p
(and (featurep 'mule) (string-match "XEmacs" emacs-version))
"Non-nil when running on XEmacs.")
;;;------------------------------------------------------------
;;; some useful macros
;;;------------------------------------------------------------
;;------------------------------------------------------------
;; convenient funcs for pstr (points with string region)
;; pstr = (command-begin-point command-end-point command-str)
;;------------------------------------------------------------
(defmacro manued-get-first-point (pstr)
"pstr からコマンドの初めの point を返す"
`(car ,pstr))
(defmacro manued-get-end-point (pstr)
"pstr からコマンドの終わりの point を返す"
`(car (cdr ,pstr)))
(defmacro manued-get-command-str (pstr)
"pstr からコマンド文字列を返す"
`(car (cdr (cdr ,pstr))))
(defmacro manued-command-eq (pstr command-chars)
"pstr 中のコマンド文字列がコマンド文字列(command-chars)と一致する場
合に t を返す"
`(string-equal
(manued-get-command-str ,pstr) ,command-chars))
;;;------------------------------------------------------------
;;; manued version
;;;------------------------------------------------------------
(defun manued-show-version ()
"Print manued version.
manued のバージョンを知らせる."
(interactive)
(cond ((interactive-p)
(message "Manued version %s of %s"
manued-version-num manued-build-day))))
;;;
;;; Variable declarations
;;;
;;------------------------------
;; related manued command variables
;;------------------------------
(defvar manued-l-parenthesis-str "["
"* Start string of manued command. : default is `['
真鵺道のコマンドのはじまりを示す文字列")
(make-variable-buffer-local 'manued-l-parenthesis-str)
(defvar manued-r-parenthesis-str "]"
"* End string of manued command. : default is `]'
真鵺道のコマンドの終了を示す文字列")
(make-variable-buffer-local 'manued-r-parenthesis-str)
(defvar manued-swap-str "|"
"* String of manued swap-command. : default is '|'
'A|B|C' means to swap A with C, then A|B|C will be C|B|A.
Especially, 'A||C' means to swap A and C, then A||C will be C||A.
交換コマンド文字列 : デフォルトは '|':
A|B|C ならば A と C を入れ換える．したがって A|B|C は C|B|A となる．
特に 'A||C' は A と C の入れ換えを意味する．したがって，
A||C は C||A となる．")
(make-variable-buffer-local 'manued-swap-str)
(defvar manued-delete-str "/"
"* String of manued delete-command . : default is '/'
'A/B' means to substitute A by B, then A/B will be B.
Especially, '/B' means to insert B and 'A/' means to delete A.
消去コマンド文字列 デフォルトは '/':
A/B ならば A を B で置き換える．
特に '/B' は B の挿入を意味し，'A/' は A の削除を意味する.")
(make-variable-buffer-local 'manued-delete-str)
(defvar manued-comment-str ";"
"* String of maenud comment command. : default is `;'
comment out until manued-r-parenthesis-str.
コメント文字． デフォルトは ';':
真鵺道コマンドの終りまでをコメントとみなす．")
(make-variable-buffer-local 'manued-comment-str)
(defvar manued-escape-str "~"
"* Escape string. : default is `~'
This string can escape a next adjacent manued command.
エスケープ文字．デフォルトは '~':
次の真鵺道コマンド文字をエスケープする．")
(make-variable-buffer-local 'manued-escape-str)
(defvar manued-pretty-print-format-delete-list
'("\\textnormal{%s}" "\\textbf{%s}" "\\textit{%s}")
"* manued pretty print format strings list for delete command.
'(delete-part-format replaced-part-format comment-part-format)
as the default, [A/B;C] will be print out:
\\textnormal{A}\\textbf{B}\\textit{C}
消去コマンド用の pretty print の際に利用される format のリスト
デフォルトでは，[A/B;C] は次のように出力される:
\\textnormal{A}\\textbf{B}\\textit{C}")
(make-variable-buffer-local 'manued-pretty-print-format-delete-list)
(defvar manued-pretty-print-format-swap-list
'("\\textbf{%s}---" "\\textbf{%s}" "---\\textbf{%s}" "(\\textit{%s})")
"* manued pretty print format strings list for swap command.
'(alpha-part-format beta-part-format gamma-part-format comment-part-format)
as the default, [A|B|C;D] will be print out:
\\textbf{%s}---\\textbf{%s}---\\textbf{%s}(\\textit{%s})
交換コマンド用の pretty print の際に利用される format のリスト
デフォルトでは，[A|B|C;D] は次のように出力される:
\\textbf{%s}---\\textbf{%s}---\\textbf{%s}(\\textit{%s})
")
(make-variable-buffer-local 'manued-pretty-print-format-swap-list)
(defvar manued-pretty-print-on-p nil
"* manued pretty print on.
If this is t, you will get revised/original document with pretty
print style. The style will be changed by variables
manued-pretty-print-format-swap-list and
manued-pretty-print-format-delete-list.
pretty print を off にする．
もしこの値が t の場合には，文書を整形した場合に pretty print style で
出力されます．そのスタイルは変数 manued-pretty-print-format-swap-list と
manued-pretty-print-format-delete-list で制御されます．")
(make-variable-buffer-local 'manued-pretty-print-on-p)
(defvar manued-pretty-print-null-comment-out-p nil
"* When t and there is no comment part, comment is considered as
\"\" and output comment part in pretty print mode. When nil and there
is no comment part, no output for comment part. Notice. This is not
buffer local variable.
この値が t の場合でかつコメントが無い場合，空のコメントがあると考えて
format の引数に \"\" が渡され，出力されます．もしこの変数が nil の場合で
コメント部分が存在しない場合には，コメント部分は出力されません．
この変数は buffer local ではありません．")
(defconst manued-defversion-str manued-version-num
"* String of manued version number. : default is same as version
number of this code.
バージョン番号を示す文字 : デフォルトはこのコードのバージョン番号")
;;------------------------------
;; related `Find and set def* pattern'.
;;------------------------------
(defvar manued-doc-begin-pat "-*-*- BEGINMANUED -*-*-"
"* This pattern indicates the beginning of a manued document.
Default is `-*-*- BEGINMANUED -*-*-'. There is no such pattern in
the document, start point of the manued document is set to `point-min'.
When this variable is nil, beginning point is always `point-min'.
真鵺道の文書の最初を示す文字列．この文字列が文書中に存在しない場合には
`point-min' が先頭として用いられる．また，このシンボルが nil の場合に
は常に `point-min' が真鵺道文書の始まりとみなされる．")
(make-variable-buffer-local 'manued-doc-begin-pat)
(defvar manued-doc-end-pat "-*-*- ENDMANUED -*-*-"
"* This pattern indicates end of a manued document.
default is `-*-*- ENDMANUED -*-*-'. There is no such pattern in
the document, enx d point of the manued document is set to `point-max'.
When this variable is nil, beginning point is always `point-max'.
真鵺道の文書の最後を示す文字列．この文字列が文書中に存在しない場合には
`point-max' が最後として用いられる．また，このシンボルが nil の場合に
は常に `point-max' が真鵺道文書の始まりとみなされる．")
(make-variable-buffer-local 'manued-doc-end-pat)
(defconst manued-def-alist
'(("defLparenthesis" manued-l-parenthesis-str)
("defRparenthesis" manued-r-parenthesis-str)
("defswap" manued-swap-str)
("defdelete" manued-delete-str)
("defcomment" manued-comment-str)
("defescape" manued-escape-str)
("deforder" manued-order-str)
("defversion" manued-defversion-str))
"manued command definition strings and symbols
真鵺道のコマンド宣言定義文字列とそのシンボル")
(defvar manued-defcommand-head-str-list
'("%" "%%" ; for TeX
)
"list of manued defcommand header strings.
This strings are ignored when they added at head of manued command
definition string.
There is some cases that we want to comment out the manued
defcommands, for example using manued in TeX document. We can write
defcommands like below.
%%defparentheses [ ]
%%defdelete /
These defcommands are recognized by manued.el and TeX ignore these
commands.
この文字列のリストには，真鵺道のコマンド宣言定義文字列の前に付加した場
合に無視する文字列を含める．たとえば TeX の文書中で真鵺道を利用する場
合，以下のように真鵺道定義コマンドを TeX のコメント部に含める
%%defparentheses [ ]
%%defdelete /
こうすると，manued.el はこれを defcommand として認識し，さらに TeX で
はこの部分を無視するので，透過的に manued を利用可能である．")
(make-variable-buffer-local 'manued-defcommand-head-str-list)
;;--------------------
;; hilit related defvar
;;--------------------
(defvar manued-use-color-hilit 'follow-font-lock-mode
"t when using color hilit. However `window-system' is nil, this
value is set to nil. When this is 'follow-font-lock-mode, follow font
lock mode.
色を使ってハイライトする場合には t，ただし，window-system が nil の場
合には nil がセットされる．'follow-font-lock-mode の場合には
font-lock-modeに従う．")
(make-variable-buffer-local 'manued-use-color-hilit)
;; hilit color
(defvar manued-first-hilit-color-list
'("red" ; delete first color
"gray60" ; delete last color
"blue" ; swap alpha color
"red" ; swap beta color
"green4" ; swap gamma color
"BlueViolet" ; comment color
"gray60") ; command color
"* hilit for first part of command.")
(make-variable-buffer-local 'manued-first-hilit-color-list)
(defvar manued-last-hilit-color-list
'("gray60" ; delete first color
"red" ; delete last color
"blue" ; swap alpha color
"red" ; swap beta color
"green4" ; swap gamma color
"BlueViolet" ; comment color
"gray60") ; command color
"* hilit for last part of command")
(make-variable-buffer-local 'manued-last-hilit-color-list)
;;------------------------------
;; insert command related variables
;;------------------------------
(defvar manued-is-delete-command-with-comment-on t
"Control insert-delete-command inserts one comment command or not.
When manued-is-delete-command-with-comment-on is t.
manued-insert-delete-command ... insert comment
manued-insert-delete-command-toggle-comment ... not insert comment
When manued-is-delete-command-with-comment-on is nil.
manued-insert-delete-command ... not insert comment
manued-insert-delete-command-toggle-comment ... insert comment
真鵺道 command 内部でコメント文字を挿入するかしないかを制御する．t の
時には default で manued-insert-delete-command はコメント文字を挿入する．た
だし，manued-insert-delete-command-toggle-comment コマンドは逆の動作をする．
")
(make-variable-buffer-local 'manued-is-delete-command-with-comment-on)
(defvar manued-is-swap-command-with-comment-on t
"Control insert-swap-command inserts one comment command or not.
When manued-is-swap-command-with-comment-on is t.
manued-insert-swap-command ... insert comment
manued-insert-swap-command-toggle-comment ... not insert comment
When manued-is-swap-command-with-comment-on is nil.
manued-insert-swap-command ... not insert comment
manued-insert-swap-command-toggle-comment ... insert comment
真鵺道 command 内部でコメント文字を挿入するかしないかを制御する．t の
時には default で manued-insert-swap-command はコメント文字を挿入する．た
だし，manued-insert-swap-command-toggle-comment コマンドは逆の動作をする．
")
(make-variable-buffer-local 'manued-is-swap-command-with-comment-on)
;;============================================================
;; Find and set def* pattern.
;;============================================================
;;
;; def* の後ろに続く非空白文字何文字かをその def のパターンとする
;; 現在は以下のものをサポートする．後ろのものは default 値
;;
;; defparentheses [ ]
;; ; defLparenthesis [ (will be obsoleted but now support)
;; ; defRparenthesis ] (will be obsoleted but now support)
;; defswap |
;; defdelete /
;; defcomment ;
;; defescape ~
;; defversion manued-version-num
;;
;;
;; 最初は位置のキャッシュはしないことにする
;; 次は編集されたかどうかを見るようにする
;;
;(defvar manued-doc-begin-point nil
; "The cache of the beginnig point of manued document.
; 真鵺道文書のスタートポイントのキャッシュ")
;(defvar manued-doc-end-point nil
; "The cache of the end point of manued document.
; 真鵺道文書のエンドポイントのキャッシュ")
;;
;; 真鵺道文書のはじめを探す
;;
(defun manued-get-doc-begin-point ()
"Find beggining point of the manued document.
Find beginning pattern of a manued document and return the point. If
begging pattern is not founded in the manued document, return the
`point-min'. The beginning pattern is `manued-doc-begin-pat'.
真鵺道文書の最初の位置を探し，そのポイントを返す．もし真鵺道文書中に真
鵺道文書開始パターンがみつからない場合には文書の最初 `point-min' へ飛
ぶ．真鵺道文書開始パターンは `manued-doc-begin-pat' が保持している．"
(if (null manued-doc-begin-pat)
(point-min)
(save-excursion
(goto-char (point-min))
(if (search-forward manued-doc-begin-pat nil t)
(match-beginning 0) ; found
(point-min))))) ; not found
;;
;; 真鵺道文書の終わりを探す
;;
(defun manued-get-doc-end-point ()
"Find end point of the manued document.
Find end pattern of a manued document and return the point. If
end pattern is not founded in the manued document, return the
`point-max'. The end pattern is `manued-doc-end-pat'.
真鵺道文書の終わりの位置を探し，そのポイントを返す．もし真鵺道文書中に
真鵺道文書開始パターンがみつからない場合には文書の最初 `point-min' へ
飛ぶ．真鵺道文書開始パターンは `manued-doc-begin-pat' が保持している．
"
(if (null manued-doc-end-pat)
(point-max)
(save-excursion
(goto-char (point-max))
(if (search-backward manued-doc-end-pat nil t)
(match-end 0) ; found
(point-max))))) ; not found
;;;------------------------------
;;; defcommand を探してセットする
;;;------------------------------
;; 一引数の一つの defcommand を探してセットする
(defun manued-search-set-def-one (decstr-str)
"Find a manued command definition string `decstr-str' and set manued
command pattern.
See also the `manued-def-alist' which is a list of manued command
declarations and variables.
一つの真鵺道コマンド宣言文字列 `decstr-str' を探してその文字列に対応す
る文字列をセットする．
`manued-def-alist' が真鵺道コマンド宣言文字列とその変数を保持している
ので参照のこと．"
(let ((non-whitespace-pat "[ |\t]+\\([^ |\t|$\n]+\\)"))
(if (re-search-forward
(concat "^" (car decstr-str) non-whitespace-pat) nil t)
(progn
(let ((b (match-beginning 1)) (e (match-end 1)))
(if (< b e)
(set (car (cdr decstr-str))
(buffer-substring-no-properties b e))))))))
;; 二引数の一つの defcommand を探してセットする
(defun manued-search-set-defparentheses-with-comment (comment-str)
"Find defparentheses and set values. This method is for
defparentheses only.
defparentheses を探し，値をセットする．comment-str を先頭に付加する文
字列．"
(if (re-search-forward
(concat "^" comment-str "defparentheses[ |\t]+") nil t)
;; 空白でない2つの引数を探す．このregexを複数重ねていけば指定
;; 個の引数を扱うことにはなる
(if (looking-at "\\([^ |\t|$\n]+\\)[ |\t]+\\([^ |\t|$\n]+\\)")
(progn
(setq manued-l-parenthesis-str
(buffer-substring-no-properties
(match-beginning 1) (match-end 1)))
(setq manued-r-parenthesis-str
(buffer-substring-no-properties
(match-beginning 2) (match-end 2))))
(error (format ":Two arguments are needed for defparentheses."))
nil)
nil))
;;
;; 全ての defcommand をセットする
;;
(defvar manued-header-is-found nil) ; header が真鵺道文書中にあるか
(defun manued-search-set-defcommands ()
"find all manued command declarations in a dcument.
全ての真鵺道コマンド宣言文字列を文書中から探し出し，真鵺道コマンドをセッ
トする．
See also `manued-search-set-oneargdefs'."
;; headerを再び探す
(setq manued-header-is-found nil)
;; defparentheses を探しセットする :
(manued-search-set-defparentheses)
;; 一引数の def* を探しセットする
(manued-search-set-oneargdefs manued-def-alist))
;;
;; defparentheses を探しその値をセットする :
;; これだけdefcommandの中で2引数なので別にする．他に複数引数のものが
;; 出てくれば全てのdefcommandは複数引数として一般化して対処すべきだが，
;; 今はこれしかないので多少add-hocではあるが，このように対処した．
;;
(defun manued-search-set-defparentheses ()
(goto-char (manued-get-doc-begin-point)) ; goto begin
(if (manued-search-set-defparentheses-with-comment "") ; serach and set one
(setq manued-header-is-found t) ; 素の defparentheses を発見
;; defparentheses が素で存在しない場合コメント文字を加えてみる
(let ((comment-head-list manued-defcommand-head-str-list))
(while comment-head-list
(if (manued-search-set-defparentheses-with-comment
(car comment-head-list))
(progn ; コメント + コマンドが存在した
(setq comment-head-list nil)
(setq manued-header-is-found t))
(setq comment-head-list (cdr comment-head-list)))))))
;;
;; manued-doc-begin-pat から初めて manued-def-alist 中のパターンに合致
;; する文字列を探しその引数をセットする．一引数のdefcommandのみを扱う．
;;
(defun manued-search-set-oneargdefs (def-alist)
"find one argument manued command declarations in a dcument.
一引数の真鵺道コマンド宣言文字列を文書中から探し出し，真鵺道コマンドを
セットする．
See also `manued-search-set-def-one'."
(while def-alist
(goto-char (manued-get-doc-begin-point)) ; goto begin
(let ((defcom (car def-alist)))
(if (manued-search-set-def-one defcom) ; serach and set one
(setq manued-header-is-found t) ; 素の defcommand を発見
;; defcommand が素で存在しない場合コメント文字を加えてみる
(let ((comment-head-list manued-defcommand-head-str-list))
(while comment-head-list
(if (manued-search-set-def-one
(cons (concat (car comment-head-list) (car defcom))
(cdr defcom)))
(progn ; コメント + コマンドが存在した
(setq comment-head-list nil)
(setq manued-header-is-found t))
(setq comment-head-list (cdr comment-head-list)))))
;; else list の要素があるだけ繰り返す
))
(setq def-alist (cdr def-alist)))
;; 古いバージョンのものと互換を持たせるための作業を行う
(manued-dispatch-for-old-version)
;; defcommand の一貫性は保たれているか
(manued-check-defcommand-consistency)
;; 全て defcommand をセットしたら order を決める (deforder を反映させる)
(manued-set-order-from-order-str)
manued-header-is-found)
;;
;; It is error when the same strings are used in defcommand.
;; ex. Error if l-parenthesis-str and r-parenthesis-str are the
;; same string.
;;
(defun manued-check-defcommand-consistency ()
(let ((compared-list manued-def-alist))
(while (not (null compared-list))
(let* ((compared-def (car compared-list))
(target-list (cdr compared-list))
(compared-str nil)
(target-str nil))
(while (not (null target-list))
(let* ((target-def (car target-list))
(s0 (symbol-value (car (cdr compared-def))))
(s1 (symbol-value (car (cdr target-def)))))
(if (<= (length s0) (length s1))
(progn
(setq compared-str s0)
(setq target-str (substring s1 0 (length s0))))
(progn
(setq compared-str (substring s0 0 (length s1)))
(setq target-str s1)))
(if (string-equal compared-str target-str)
;; (if (string-equal s0 s1)
(progn
(goto-char (manued-get-doc-begin-point))
(if (search-forward (car compared-def) nil t)
(setq hilit-err-occur-pos (match-beginning 0)))
(error (format
"%s and %s are the same, check your defcommand."
(car compared-def) (car target-def))))))
(setq target-list (cdr target-list))))
(setq compared-list (cdr compared-list)))))
;;;------------------------------------------------------------
;;; manued-order-str の値によって order を決める
;;;------------------------------------------------------------
;; order indicating string
(defvar manued-order-str "older-first"
"* delete order.
The form of the manued command is [first/last]. ``older''
indicates original document and ``newer'' indicates revised
document. This string sets the variable `manued-is-order-older-first'.
真鵺道消去コマンドの適用順．消去コマンドの内容を [first/last]
とする． `older' は元文書を，`newer' は変更後の文書を示す．この文字列
にしたがって `manued-is-order-older-first' の値がセットされる．
-------------------------+-----------------+----------------------------
manued-order-str | change from to | manued-is-order-older-first
-------------------------+-----------------+----------------------------
older-first, newer-last | first -> last | t
older-last, newer-first| last -> first | nil
-------------------------+-----------------+----------------------------")
(defvar manued-is-order-older-first t
"Applying swap-command order.
When t, [first/last] will change first -> last.
消去コマンドの [first/last] のどちらが訂正先かを示す．
[訂正前/訂正後]の場合に t，その逆 ([訂正後/訂正前]) の時に nil．")
;;
;; set delete command order according to order string
;; order 文字列に従って delete command の前後を決定する
;;
(defun manued-set-order-from-order-str ()
"set delete command order according to order string."
(cond ((member manued-order-str '("older-first" "newer-last"))
(setq manued-is-order-older-first t))
((member manued-order-str '("older-last" "newer-first"))
(setq manued-is-order-older-first nil))
(t
(setq manued-order-str "older-first")
(setq manued-is-order-older-first t)
(goto-char (manued-get-doc-begin-point))
(search-forward "deforder")
(setq hilit-err-occur-pos (match-beginning 0))
(error (format "illeal deforder str (setted %s)" manued-order-str)))))
;;------------------------------------------------------------
;; insert manued header
;;------------------------------------------------------------
(defvar manued-is-auto-insert-header '(t t nil)
"setting for defcommands insertion
'(is-auto-insert is-query-when-insert insert-point)
When `is-auto-insert' is t, manued.el inserts defcommands in the
current buffer in the case of no defcommands in the buffer. If
`is-auto-insert' is nil, manued.el does not insert defcommands.
When the second element `is-query-when-insert' is t, manued.el asks to
user `insert-manued header (y or n)', otherwise no question. This is
only effective when `is-auto-insert' is t.
The third element of this list `insert-point' indicates insert point
of defcommands. The meaning of value is as folowing.
t current point
nil (point-min)
number point as a number
バッファに defcommand を挿入する場合の設定
`is-auto-insert' が t の場合，もし現在のバッファにdefcommandが無い場合に
はmanued.elはdefcommandを現在のバッファに挿入します．nilの場合には何もし
ません．
2番目の要素`is-query-when-insert'がtの場合，manued.elはユーザに
defcommandを挿入して良いか尋ねるようになります．nilの場合には尋ねません．
これは，`is-auto-insert'がtの場合に有効です．
3番目の要素である`insert-point'はdefcommandの挿入位置を指定するもので，
次のような意味を持ちます．
t 現在のポイント
nil (point-min)
number 数字で示したpoint位置
")
(defun manued-insert-header (p)
"insert manued header at point"
(interactive "d")
(goto-char p)
(insert (format "defparentheses\t%s %s\n"
manued-l-parenthesis-str manued-r-parenthesis-str))
(let ((defalist manued-def-alist) (item))
(while defalist
(setq item (car defalist))
(or (member (car item) '("defLparenthesis" "defRparenthesis"))
(insert
;; (format "%s\t%s\n" (car item) (eval (car (cdr item)))))
;; と eval を使っていたが，symbol-value を使う
(format "%s\t%s\n" (car item) (symbol-value (car (cdr item))))))
(setq defalist (cdr defalist)))))
;;
;; when non exist header, insert manued header with quary
;;
(defun manued-search-and-insert-header ()
"真鵺道 def コマンドをサーチし，存在しない場合には挿入するか尋ねる．
see variable : manued-is-auto-insert-header"
(save-excursion
(if (and (car manued-is-auto-insert-header)
(not manued-header-is-found)) ; mode に入る際に必ず呼ばれている
(let ((p) (iposinfo (car (cdr (cdr manued-is-auto-insert-header)))))
(cond ((eq t iposinfo)
(setq p (point)))
((null iposinfo)
(setq p (point-min)))
((and (numberp iposinfo) (> iposinfo 0))
(setq p iposinfo)))
(if (car (cdr manued-is-auto-insert-header))
(if (y-or-n-p "insert manued header?")
(manued-insert-header p))
(manued-insert-header p))))))
;;============================================================
;; hilit manued commands
;;============================================================
;; recenter hilit
;;------------------------------
(defun manued-recenter-hilit ()
"recenter and hilit
When color mode is enable, recenter and hilight. But when color mode
is disabled, only recenter.
recenter した後に真鵺道コマンドを hilit する．ただし，hilit を行うのは
color mode が off の時のみ．"
(interactive)
(manued-hilit)
(recenter))
;;------------------------------
;; 現在 hilit すべきものを示す.
;; manued-hilit が呼ばれた時にはこの変数を見て hilit-older か
;; hilit-newer かを判定する．t のときには newer を hilit する．
;;------------------------------
(defvar manued-is-now-hilit-newer t)
;;------------------------------
;; hilit
;;------------------------------
(defun manued-hilit ()
"hilit manued command.
When `manued-use-color-hilit' is t, hilit manued command according to
the value of `manued-is-now-hilit-newer'.
真鵺道コマンドを hilit する．
もし `manued-use-color-hilit' が t ならば manued command を hilit する．
この時，`manued-is-now-hilit-newer' が t ならば newer を hilit し，nil
ならば older を hilit する．"
(if (manued-guess-color-mode)
(progn
(if manued-is-now-hilit-newer
(manued-hilit-newer)
(manued-hilit-older)))
(manued-unhilit-current-buffer)))
;;------------------------------
;; unhilit current buffer
;;------------------------------
(defun manued-unhilit-current-buffer ()
(remove-text-properties (point-min) (point-max) '(face nil)))
;;
;; hilit newer
;;
(defun manued-hilit-newer ()
"hilit newer part within manued command.
文章中の真鵺道コマンド中の訂正後部分をハイライトする．"
(interactive)
(let ((hilit-err-occur-pos nil))
(condition-case err-message
(save-excursion
(manued-init-vars)
(goto-char (manued-get-doc-begin-point))
(setq manued-is-now-hilit-newer t)
(if manued-is-order-older-first
(manued-set-hilit-color manued-last-hilit-color-list)
(manued-set-hilit-color manued-first-hilit-color-list))
(while (manued-hilit-manuedexp)))
(error ; error handling
(if hilit-err-occur-pos
(goto-char hilit-err-occur-pos))
(error (format "Error! : manued-hilit-newer : %s" err-message))))))
;;
;; hilit older
;;
(defun manued-hilit-older ()
"hilit older part within manued command.
文章中の真鵺道コマンド中の訂正前部分をハイライトする．"
(interactive)
(let ((hilit-err-occur-pos nil))
(condition-case err-message
(save-excursion
(manued-init-vars)
(goto-char (manued-get-doc-begin-point))
(setq manued-is-now-hilit-newer nil)
(if manued-is-order-older-first
(manued-set-hilit-color manued-first-hilit-color-list)
(manued-set-hilit-color manued-last-hilit-color-list))
(while (manued-hilit-manuedexp)))
(error ; error handling
(if hilit-err-occur-pos
(goto-char hilit-err-occur-pos))
(error (format "Error! : manued-hilit-older : %s" err-message))))))
;;
;; hilit toplevel (hilit-manuedexp see manued.grammer)
;; lap ... LookAhead Pstr
;;
(defun manued-hilit-manuedexp ()
"hilit all manued command at top level.
真鵺道の文書中のコマンドを全てハイライトする．"
(let ((cont t))
(while cont
(let ((lap (manued-search-nonescaped-command-in-hirabun ; [ を探す
(manued-get-doc-end-point))))
(if lap ; found [. この lap は [ である
(progn
(manued-hilit-one-command lap)
;; colored-pos-pstr はこれまで色を塗った場所を示す大域的
;; ポインタ，最初の region は delete-first と仮定する
(let ((colored-pos-pstr lap))
(manued-hilit-manued-term 'manued-com-delete-first)))
(setq cont nil)))))) ; not found
;;
;; hilit manued-term : LL(1), see Dragon book.
;;
(defun manued-hilit-manued-term (cur-command)
(let ((cont t)
(lap nil)) ; lookahead-pstr
(while cont
(setq lap (manued-search-nonescaped-command
(manued-all-command-pat) (manued-get-doc-end-point)))
(if (null lap)
;; No command is found. At least, `]' must be found here.
;; This must be error.
(progn
(manued-hilit-can-not-find-end-paren colored-pos-pstr)
(setq cont nil))
(progn
(manued-hilit-one-command lap) ; コマンド処理
;; これまでの範囲を処理
(cond
;; ; comment in and exit this level
((manued-command-eq lap manued-comment-str)
(if (or (eq cur-command 'manued-com-delete-first)
(eq cur-command 'manued-com-delete-last)
(eq cur-command 'manued-com-swap-gamma))
(progn (manued-hilit-one-region
colored-pos-pstr lap cur-command)
;; 次の cur-command は hilit-commet がコメント
;; ということを知っているので冗長だが，プログラ
;; ムとしての一貫性を取るためにあえて setq する
(setq cur-command 'manued-com-comment)
(manued-hilit-comment lap)
(setq cont nil))
(progn
(setq hilit-err-occur-pos (manued-get-first-point lap))
(error "illegal command, is command right?"))))
;; [ recursion
((manued-command-eq lap manued-l-parenthesis-str)
(manued-hilit-one-region colored-pos-pstr lap cur-command)
(manued-hilit-manued-term 'manued-com-delete-first))
;; / delete
((manued-command-eq lap manued-delete-str)
(manued-hilit-one-region colored-pos-pstr lap cur-command)
(setq cur-command 'manued-com-delete-last))
;; | swap
((manued-command-eq lap manued-swap-str)
(cond
((eq cur-command 'manued-com-delete-first)
(setq cur-command 'manued-com-swap-alpha) ; ここでswapとわかる
(manued-hilit-one-region colored-pos-pstr lap cur-command)
(setq cur-command 'manued-com-swap-beta))
((eq cur-command 'manued-com-swap-beta)
(manued-hilit-one-region colored-pos-pstr lap cur-command)
(setq cur-command 'manued-com-swap-gamma))
(t
(setq hilit-err-occur-pos (manued-get-first-point lap))
(error "illegal command, here must be swap command region."))))
;; ]
((manued-command-eq lap manued-r-parenthesis-str)
(manued-hilit-one-region colored-pos-pstr lap cur-command)
(setq cont nil)) ; return; exit loop
(t
(setq hilit-err-occur-pos (manued-get-first-point lap))
(error "Internal error. I do not know such command."))))))))
;;
;; 終了の括弧がみつからない場合のエラー処理
;;
(defun manued-hilit-can-not-find-end-paren (pstr)
(setq hilit-err-occur-pos (manued-get-first-point pstr))
(error (format "hilit-one-level : lack of `%s' of this `%s'"
manued-r-parenthesis-str manued-l-parenthesis-str)))
;;
;; hilit-commet
;;
(defun manued-hilit-comment (pstr)
(let ((lap nil))
(setq lap (manued-search-nonescaped-command
(manued-outof-command-pat) (manued-get-doc-end-point)))
(if (or (null lap) (not (manued-command-eq lap manued-r-parenthesis-str)))
(progn
(setq hilit-err-occur-pos (manued-get-first-point pstr))
(error "Missing r-parenthesis for the end of comment."))
(progn
(manued-hilit-one-command lap)
(manued-hilit-one-region colored-pos-pstr lap 'manued-com-comment)))))
;;
;; 一つの manued コマンド (ex. [, ], /, |, ;) の hilit
;;
(defun manued-hilit-one-command (pstr)
"一つの真鵺道コマンドを hilit する．"
(put-text-property (manued-get-first-point pstr)
(manued-get-end-point pstr)
'face
'manued-command-face))
;;
;; 指定した色で指定範囲を hilit
;;
(defun manued-hilit-one-color (begin-pstr end-pstr color)
"真鵺道コマンド中の連続した部分を指定した色で hilit する．
hilit a manued region with indicated color-face."
(put-text-property (manued-get-end-point begin-pstr)
(manued-get-first-point end-pstr)
'face
color))
;;
;; ある範囲を色を選択してハイライトする
;; どこまで色を塗ったかを colored-pos-pstr に記録する
;;
(defun manued-hilit-one-region (beg-pstr end-pstr cur-command)
"hilit a manued command region.
一つの真鵺道コマンドの範囲を指定するとその範囲をハイライトする．"
(cond ((eq cur-command 'manued-com-delete-first) ; [first/]
(manued-hilit-one-color beg-pstr end-pstr 'manued-delete-first-face))
((eq cur-command 'manued-com-delete-last) ; [/last]
(manued-hilit-one-color beg-pstr end-pstr 'manued-delete-last-face))
((eq cur-command 'manued-com-swap-alpha) ; [alpha||]
(manued-hilit-one-color beg-pstr end-pstr 'manued-swap-alpha-face))
((eq cur-command 'manued-com-swap-beta) ; [|beta|]
(manued-hilit-one-color beg-pstr end-pstr 'manued-swap-beta-face))
((eq cur-command 'manued-com-swap-gamma) ; [||gamma]
(manued-hilit-one-color beg-pstr end-pstr 'manued-swap-gamma-face))
((eq cur-command 'manued-com-comment) ; [;comment]
(manued-hilit-one-color beg-pstr end-pstr 'manued-comment-face))
(t (error "Unknown manued command and color.")))
(setq colored-pos-pstr end-pstr))
;;
;; set hilit color
;;
(defun manued-set-hilit-color (color-val-list)
"hilit 色の設定"
(let ((color-sym '(manued-delete-first-face
manued-delete-last-face
manued-swap-alpha-face
manued-swap-beta-face
manued-swap-gamma-face
manued-comment-face
manued-command-face))
(color-val color-val-list))
;; (mapcar 'set color-sym color-val) は elisp ではできない．引数は一つ
(while color-sym
(let ((face-sym (car color-sym)))
(make-face face-sym)
(set-face-foreground face-sym (car color-val))
(setq color-sym (cdr color-sym))
(setq color-val (cdr color-val))))))
;;============================================================
;; search manued command
;;============================================================
;;
;; search-nonescaped-command (coms-regpat end-point)
;; エスケープを考えてコマンドをサーチする
;;
;; エスケープの意味は，「エスケープ文字の次の文字は飛ばす」ということ
;; に定義する
;;
(defun manued-search-nonescaped-command (coms-regpat end-point)
"エスケープを考慮してコマンドをサーチする．
search-coms-regpat : サーチする command 文字の regex パターン
end-point : どこまで探すか(point)
escape されていないコマンドを探し，みつかったらそのコマンドの
``begin-point end-point コマンド文字列'' のリストを返す．みつからな
かったら nilを返す"
(catch 'tag
(while t
(let ((find-com (manued-search-command coms-regpat end-point)))
(if (not find-com)
(throw 'tag nil) ; コマンドはない
;; escape 文字の場合にはサーチする escape と L-parenthesis
;; との組で与えられている．ex. ~[
(let (; (fpos (manued-get-first-point find-com)) ; コマンド群の最初
(epos (manued-get-end-point find-com))) ; 終わり
(goto-char (manued-get-first-point find-com)) ; コマンド位置へ移動
(if (looking-at (regexp-quote manued-escape-str)) ; escape 文字か?
(progn ; escape str だった
(goto-char epos) ; escの後へ移動 ESCPAT^COMPAT
(forward-char 1)) ; 1文字飛ばす
(progn ; escape 文字でなかった
(goto-char epos) ; 'COMPAT^'
(throw 'tag find-com)))))))))
;;
;; serach-command (search-coms-regpat end-point)