cgit.sxemacs.org Git - packages/blob - mule-packages/egg-its/egg.el

   1 ;; Japanese Character Input Package for Egg
   2 ;; Coded by S.Tomura, Electrotechnical Lab. (tomura@etl.go.jp)
   3
   4 ;; This file is part of Egg on Mule (Multilingal Environment)
   5
   6 ;; Egg is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2, or (at your option)
   9 ;; any later version.
  10
  11 ;; Egg is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19
  20 ;; This version is heavily modified for XEmacs, and the current maintainer
  21 ;; is Jareth Hein <jareth@xemacs.org> or <jareth@camelot.co.jp>.
  22
  23 ;;;==================================================================
  24 ;;;
  25 ;;; \e$BF|K\8l4D6-\e(B \e$B!V$?$^$4!W\e(B \e$BBh#3HG\e(B
  26 ;;;
  27 ;;;===================================================================
  28
  29 ;;;
  30 ;;;\e$B!V$?$^$4!W$O%M%C%H%o!<%/$+$J4A;zJQ49%5!<%P$rMxMQ$7!"\e(BMule \e$B$G$NF|K\\e(B
  31 ;;; \e$B8l4D6-$rDs6!$9$k%7%9%F%`$G$9!#!V$?$^$4!WBh#2HG$G$O\e(B Wnn V3 \e$B$*$h$S\e(B
  32 ;;; Wnn V4 \e$B$N$+$J4A;zJQ49%5!<%P$r;HMQ$7$F$$$^$9!#\e(B
  33 ;;;
  34
  35 ;;; \e$BL>A0$O\e(B \e$B!VBt;3\e(B/\e$BBT$?$;$F\e(B/\e$B$4$a$s$J$5$$!W$N3FJ8@a$N@hF,#12;$G$"$k!V$?!W\e(B
  36 ;;; \e$B$H!V$^!W$H!V$4!W$r<h$C$F!"!V$?$^$4!W$H8@$$$^$9!#EE;R5;=QAm9g8&5f=j\e(B
  37 ;;; \e$B$N6S8+\e(B \e$BH~5.;R;a$NL?L>$K0M$k$b$N$G$9!#\e(Begg \e$B$O!V$?$^$4!W$N1QLu$G$9!#\e(B
  38
  39 ;;;
  40 ;;; \e$B;HMQK!$O\e(B info/egg-jp \e$B$r8+$F2<$5$$!#\e(B
  41 ;;;
  42
  43 ;;;
  44 ;;; \e$B!V$?$^$4!W$K4X$9$kDs0F!"Cn>pJs$O\e(B tomura@etl.go.jp \e$B$K$*Aw$j2<$5$$!#\e(B
  45 ;;;
  46
  47 ;;;
  48 ;;;                      \e$B")\e(B 305 \e$B0q>k8)$D$/$P;TG_1`\e(B1-1-4
  49 ;;;                      \e$BDL;:>J9)6H5;=Q1!EE;R5;=QAm9g8&5f=j\e(B
  50 ;;;                      \e$B>pJs%"!<%-%F%/%A%cIt8@8l%7%9%F%`8&5f<<\e(B
  51 ;;;
  52 ;;;                                                     \e$B8MB<\e(B \e$BE/\e(B
  53
  54 ;;;
  55 ;;; (\e$BCm0U\e(B)\e$B$3$N%U%!%$%k$O4A;z%3!<%I$r4^$s$G$$$^$9!#\e(B
  56 ;;;
  57 ;;;   \e$BBh#3HG\e(B  \e$B#1#9#9#1G/#27n\e(B  \e$B#4F|\e(B
  58 ;;;   \e$BBh#2HG\e(B  \e$B#1#9#8#9G/#67n\e(B  \e$B#1F|\e(B
  59 ;;;   \e$BBh#1HG\e(B  \e$B#1#9#8#8G/#77n#1#4F|\e(B
  60 ;;;   \e$B;CDjHG\e(B  \e$B#1#9#8#8G/#67n#2#4F|\e(B
  61
  62 ;;;===================================================================
  63 ;;;
  64 ;;; (eval-when (load) (require 'wnn-client))
  65 ;;;
  66
  67 ; last master version
  68 ;;; (defvar egg-version "3.09" "Version number of this version of Egg. ")
  69 ;;; Last modified date: Fri Sep 25 12:59:00 1992
  70 (defvar egg-version "3.10 xemacs" "Version number of this version of Egg. ")
  71 ;;; Last modified date: Wed Nov 29 20:45:00 1997
  72
  73 ;;;;  \e$B=$@5MW5a%j%9%H\e(B
  74
  75 ;;;;  read-hiragana-string, read-kanji-string \e$B$G;HMQ$9$kJ?2>L>F~NO%^%C%W$r\e(B roma-kana \e$B$K8GDj$7$J$$$GM_$7$$!%\e(B
  76
  77 ;;;;  \e$B=$@5%a%b\e(B
  78
  79 ;;; A couple of changes need to be made to XEmacs glyph/extent display functions
  80 ;;; before egg will really be able to use glyphs and extents properly.  Most
  81 ;;; notibly, cursor placement should vary depending on the open/closedness of
  82 ;;; the extent...
  83
  84 ;;; 97.10.29 modified by J.Hein <jareth@camelot-soft.com>
  85 ;;; fix to get rid of problem with C-h/backspace fuckage when in fence mode. Note
  86 ;;; that the entire egg-read-event thing is a hack and really needs to be re-implemented.
  87 ;;; I REALLY don't like the bandaids there...
  88 ;;; Also added the egg-mode function, and modified the behavior so that just loading
  89 ;;; egg will not change the user's state.
  90
  91 ;;; 97.2.05 modified by J.Hein <jhod@po.iijnet.or.jp>
  92 ;;; Lots of mods to make it XEmacs workable. Most fixes revolve around the fact that
  93 ;;; Mule/et al assumes that all events are keypress events unless specified otherwise.
  94 ;;; Also modified to work with the new charset names and API
  95
  96 ;;; 95.6.5 modified by S.Tomura <tomura@etl.go.jp>
  97 ;;; \e$BJQ49D>8e$KO"B3$7$FJQ49$9$k>l9g$rG'<1$9$k$?$a$K!"\e(B"-in-cont" \e$B$K4XO"$7$?\e(B
  98 ;;; \e$BItJ,$rDI2C$7$?!#!J$3$NItJ,$O>-Mh:F=$@5$9$kM=Dj!#!K\e(B
  99
 100 ;;; 93.6.19  modified by T.Shingu <shingu@cpr.canon.co.jp>
 101 ;;; egg:*in-fence-mode* should be buffer local.
 102
 103 ;;; 93.6.4   modified by T.Shingu <shingu@cpr.canon.co.jp>
 104 ;;; In its-defrule**, length is called instead of chars-in-string.
 105
 106 ;;; 93.3.15  modified by T.Enami <enami@sys.ptg.sony.co.jp>
 107 ;;; egg-self-insert-command simulates the original more perfectly.
 108
 109 ;;; 92.12.20 modified by S.Tomura <tomura@etl.go.jp>
 110 ;;; In its:simulate-input, sref is called instead of aref.
 111
 112 ;;; 92.12.20 modified by T.Enami <enami@sys.ptg.sony.co.jp>
 113 ;;; egg-self-insert-command calls cancel-undo-boundary to simulate original.
 114
 115 ;;; 92.11.4 modified by M.Higashida <manabu@sigmath.osaka-u.ac.jp>
 116 ;;; read-hiragana-string sets minibuffer-preprompt correctly.
 117
 118 ;;; 92.10.26, 92.10.30 modified by T.Saneto sanewo@pdp.crl.sony.co.jp
 119 ;;; typo fixed.
 120
 121 ;;; 92.10.18 modified by K. Handa <handa@etl.go.jp>
 122 ;;; special-symbol-input \e$BMQ$N%F!<%V%k$r\e(B autoload \e$B$K!#\e(B
 123 ;;; busyu.el \e$B$N\e(B autoload \e$B$N;XDj$r\e(B mule-init.el \e$B$+$i\e(B egg.el \e$B$K0\$9!#\e(B
 124
 125 ;;;  92.9.20 modified by S. Tomura
 126 ;;;; hiragana-region \e$B$NCn$N=$@5\e(B
 127
 128 ;;;; 92.9.19 modified by Y. Kawabe
 129 ;;;; some typos
 130
 131 ;;;; 92.9.19 modified by Y. Kawabe<kawabe@sramhc.sra.co.jp>
 132 ;;;; menu \e$B$NI=<(4X78$N\e(B lenght \e$B$r\e(B string-width \e$B$KCV$-49$($k!%\e(B
 133
 134 ;;; 92.8.19 modified for Mule Ver.0.9.6 by K.Handa <handa@etl.go.jp>
 135 ;;;; menu:select-from-menu calls string-width instead of length.
 136
 137 ;;;; 92.8.1 modified by S. Tomura
 138 ;;;; internal mode \e$B$rDI2C!%\e(Bits:*internal-mode-alist* \e$BDI2C!%\e(B
 139
 140 ;;;; 92.7.31 modified by S. Tomura
 141 ;;;; its-mode-map \e$B$,\e(B super mode map \e$B$r;}$D$h$&$KJQ99$7$?!%$3$l$K$h$j\e(B
 142 ;;;; mode map \e$B$,6&M-$G$-$k!%\e(B its-define-mode, get-next-map \e$B$J$I$rJQ99!%\e(B
 143 ;;;; get-next-map-locally \e$B$rDI2C!%\e(Bits-defrule** \e$B$rJQ99!%\e(B
 144
 145 ;;;; 92.7.31 modified by S. Tomura
 146 ;;;; its:make-kanji-buffer , its:*kanji* \e$B4XO"%3!<%I$r:o=|$7$?!%\e(B
 147
 148 ;;;; 92.7.31 modified by S. Tomura
 149 ;;;;  egg:select-window-hook \e$B$r=$@5$7!$\e(Bminibuffer \e$B$+$i\e(B exit \e$B$9$k$H$-$K!$\e(B
 150 ;;;; \e$B3F<oJQ?t$r\e(B default-value \e$B$KLa$9$h$&$K$7$?!%$3$l$K$h$C$F\e(B
 151 ;;;; minibuffer \e$B$KF~$kA0$K3F<o@_Dj$,2DG=$H$J$k!%\e(B
 152
 153
 154 ;; 97.2.4 Created by J.Hein to simulate Mule-2.3
 155 (defun egg-read-event ()
 156   "FSFmacs event emulator that shoves non key events into
 157 unread-command-events to facilitate translation from Mule-2.3"
 158   (let ((event (make-event))
 159         ch key)
 160     (next-command-event event)
 161     (setq key (event-key event))
 162     (if (and (key-press-event-p event)
 163              (not (event-matches-key-specifier-p event 'backspace)))
 164         (if (eq 0 (event-modifier-bits event))
 165             (setq ch (or (event-to-character event) key))
 166           (if (eq 1 (event-modifier-bits event))
 167               (setq ch
 168                     (if (characterp key)
 169                         (or (int-to-char (- (char-to-int key) 96))
 170                             (int-to-char (- (char-to-int key) 64)))
 171                       (event-to-character event)))
 172             (setq unread-command-events (list event))))
 173       (setq unread-command-events (list event)))
 174     ch))
 175
 176 (eval-when-compile (require 'egg-jsymbol))
 177
 178 ;;;
 179 ;;;----------------------------------------------------------------------
 180 ;;;
 181 ;;; Utilities
 182 ;;;
 183 ;;;----------------------------------------------------------------------
 184
 185 ;;;
 186 ;;;;
 187
 188 (defun coerce-string (form)
 189   (cond((stringp form) form)
 190        ((characterp form) (char-to-string form))))
 191
 192 (defun coerce-internal-string (form)
 193   (cond((stringp form)
 194         (if (= (length form) 1)
 195             (string-to-char form)
 196           form))
 197        ((characterp form) form)))
 198
 199 ;;; kill-all-local-variables \e$B$+$iJ]8n$9$k\e(B local variables \e$B$r;XDj$G$-$k\e(B
 200 ;;; \e$B$h$&$KJQ99$9$k!#\e(B
 201
 202 (put 'egg:*input-mode* 'permanent-local t)
 203 (put 'egg:*mode-on* 'permanent-local t)
 204 (put 'its:*current-map* 'permanent-local t)
 205 (put 'mode-line-egg-mode 'permanent-local t)
 206
 207 ;; undo functions.
 208 (make-variable-buffer-local
 209  (defvar egg-buffer-undo-list nil))
 210 (make-variable-buffer-local
 211  (defvar egg-buffer-modified-flag nil))
 212
 213 (defun suspend-undo ()
 214   (setq egg-buffer-undo-list buffer-undo-list
 215         egg-buffer-modified-flag (buffer-modified-p)))
 216
 217 (defun resume-undo-list ()
 218   (setq buffer-undo-list egg-buffer-undo-list)
 219   (if (not egg-buffer-modified-flag)
 220       (let ((time (visited-file-modtime)))
 221         (if (eq time 0) (setq time '(0 . 0)))
 222         (set 'buffer-undo-list
 223              (cons (cons t time)
 224                    buffer-undo-list)))))
 225
 226 ;;;----------------------------------------------------------------------
 227 ;;;
 228 ;;; 16\e$B?JI=8=$N\e(BJIS \e$B4A;z%3!<%I$r\e(B minibuffer \e$B$+$iFI$_9~$`\e(B
 229 ;;;
 230 ;;;----------------------------------------------------------------------
 231
 232 ;;;
 233 ;;; User entry:  jis-code-input
 234 ;;;
 235
 236 (defun jis-code-input ()
 237   (interactive)
 238   (insert-jis-code-from-minibuffer "JIS \e$B4A;z%3!<%I\e(B(16\e$B?J?tI=8=\e(B): "))
 239
 240 (defun insert-jis-code-from-minibuffer (prompt)
 241   (let ((str (read-from-minibuffer prompt)) val)
 242     (while (null (setq val (read-jis-code-from-string str)))
 243       (beep)
 244       (setq str (read-from-minibuffer prompt str)))
 245     (insert (make-char (find-charset 'japanese-jisx0208) (car val) (cdr val)))))
 246
 247 (defun hexadigit-value (ch)
 248   (cond((and (<= ?0 ch) (<= ch ?9))
 249         (- ch ?0))
 250        ((and (<= ?a ch) (<= ch ?f))
 251         (+ (- ch ?a) 10))
 252        ((and (<= ?A ch) (<= ch ?F))
 253         (+ (- ch ?A) 10))))
 254
 255 (defun read-jis-code-from-string (str)
 256   (if (and (= (length str) 4)
 257            (<= 2 (hexadigit-value (aref str 0)))
 258            (hexadigit-value (aref str 1))
 259            (<= 2 (hexadigit-value (aref str 2)))
 260            (hexadigit-value (aref str 3)))
 261   (cons (+ (* 16 (hexadigit-value (aref str 0)))
 262                (hexadigit-value (aref str 1)))
 263         (+ (* 16 (hexadigit-value (aref str 2)))
 264            (hexadigit-value (aref str 3))))))
 265
 266 ;;;----------------------------------------------------------------------
 267 ;;;
 268 ;;; \e$B!V$?$^$4!W\e(B Notification System
 269 ;;;
 270 ;;;----------------------------------------------------------------------
 271
 272 (defconst *notification-window* " *Notification* ")
 273
 274 ;;;(defmacro notify (str &rest args)
 275 ;;;  (list 'notify-internal
 276 ;;;     (cons 'format (cons str args))))
 277
 278 (defun notify (str &rest args)
 279   (notify-internal (apply 'format (cons str args))))
 280
 281 (defun notify-internal (message &optional noerase)
 282   (save-excursion
 283     (set-buffer (get-buffer-create *notification-window*))
 284     (goto-char (point-max))
 285     (setq buffer-read-only nil)
 286     (insert (substring (current-time-string) 4 19) ":: " message ?\n )
 287     (setq buffer-read-only t)
 288     (save-window-excursion
 289       (bury-buffer (current-buffer))))
 290   (message "%s" message)                ; 92.4.15 by T.Enami
 291   (if noerase
 292       nil
 293     (let ((focus-follows-mouse t))
 294       (sleep-for 1))
 295     (message "")))
 296
 297 ;;;(defmacro notify-yes-or-no-p (str &rest args)
 298 ;;;  (list 'notify-yes-or-no-p-internal
 299 ;;;     (cons 'format (cons str args))))
 300
 301 (defun notify-yes-or-no-p (str &rest args)
 302   (notify-yes-or-no-p-internal (apply 'format (cons str args))))
 303
 304 (defun notify-yes-or-no-p-internal (message)
 305   (save-window-excursion
 306     (pop-to-buffer *notification-window*)
 307     (goto-char (point-max))
 308     (setq buffer-read-only nil)
 309     (insert (substring (current-time-string) 4 19) ":: " message ?\n )
 310     (setq buffer-read-only t)
 311     (yes-or-no-p "\e$B$$$$$G$9$+!)\e(B")))
 312
 313 (defun notify-y-or-n-p (str &rest args)
 314   (notify-y-or-n-p-internal (apply 'format (cons str args))))
 315
 316 (defun notify-y-or-n-p-internal (message)
 317   (save-window-excursion
 318     (pop-to-buffer *notification-window*)
 319     (goto-char (point-max))
 320     (setq buffer-read-only nil)
 321     (insert (substring (current-time-string) 4 19) ":: " message ?\n )
 322     (setq buffer-read-only t)
 323     (y-or-n-p "\e$B$$$$$G$9$+!)\e(B")))
 324
 325 (defun select-notification ()
 326   (interactive)
 327   (pop-to-buffer *notification-window*)
 328   (setq buffer-read-only t))
 329
 330 ;;;----------------------------------------------------------------------
 331 ;;;
 332 ;;; Minibuffer Menu System
 333 ;;;
 334 ;;;----------------------------------------------------------------------
 335
 336 ;;; user-customizable variables
 337 (defvar menu:*display-item-value* nil
 338   "*Non-nil means values of items are displayed in minibuffer menu")
 339
 340 ;;; The following will be localized, added only to pacify the compiler.
 341 (defvar menu:*cur-menu*)
 342 (defvar menu:*cur-selection*)
 343 (defvar menu:*cur-selections*)
 344 (defvar menu:*cur-element-no*)
 345 (defvar menu:*cur-selection-no*)
 346 (defvar menu:*cur-element-points*)
 347 (defvar menu:*menu-stack*)
 348
 349 (defvar minibuffer-local-menu-map (make-sparse-keymap))
 350 (set-keymap-default-binding minibuffer-local-menu-map 'undefined)
 351
 352 (mapcar
 353  (lambda (elem)
 354    (define-key minibuffer-local-menu-map
 355      (car elem) (intern (format "menu:%s" (cdr elem)))))
 356  '(
 357    (" "         . next-element)
 358    ("\C-a"      . beginning-of-selection)
 359    ("\C-b"      . previous-element)
 360    ("\C-d"      . previous-element)
 361    ("\C-e"      . end-of-selection)
 362    ("\C-f"      . next-element)
 363    ("\C-g"      . quit)
 364    ("\C-h"      . previous-element)
 365    ("\C-i"      . next-element)
 366    ("\C-j"      . select)
 367    ("\C-l"      . refresh)
 368    ("\C-m"      . select)
 369    ("\C-n"      . next-selection)
 370    ("\C-p"      . previous-selection)
 371    ([backspace] . previous-element)
 372    ([clear]     . quit)
 373    ([delete]    . previous-element)
 374    ([down]      . next-selection)
 375    ([kp-down]   . next-selection)
 376    ([kp-enter]  . select)
 377    ([kp-left]   . previous-element)
 378    ([kp-right]  . next-element)
 379    ([kp-tab]    . next-element)
 380    ([kp-up]     . previous-selection)
 381    ([left]      . previous-element)
 382    ([next]      . next-selection)
 383    ([prior]     . previous-selection)
 384    ([return]    . select)
 385    ([right]     . next-element)
 386    ([tab]       . next-element)
 387    ([up]        . previous-selection)
 388    ))
 389
 390 ;;; 0 .. 9 A .. Z a .. z
 391 (mapcar
 392  (lambda (char)
 393    (define-key minibuffer-local-menu-map (char-to-string char)
 394      'menu:goto-nth-element))
 395  "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
 396
 397 ;;; kp-0 .. kp-9
 398 (mapcar
 399  (lambda (key)
 400    (define-key minibuffer-local-menu-map key 'menu:goto-nth-element))
 401  (list [kp-0] [kp-1] [kp-2] [kp-3] [kp-4] [kp-5] [kp-6] [kp-7] [kp-8] [kp-9]))
 402
 403 ;;;
 404 ;;; predicates and selectors for menu
 405 ;;;
 406 ;; <menu> ::= ( menu <prompt string> <items> )
 407 ;; <items> ::= ( <item> ... )
 408 ;; <item> ::= ( <string> . <value> ) | <string>
 409 ;;         |  ( <char>   . <value> ) | <char>
 410 ;; <value> :: = <menu> | <other object>
 411 ;;
 412 (defun menu:menup (value)
 413   (and (listp value)
 414        (eq (car value) 'menu)))
 415
 416 (defun menu:menu-prompt (&optional menu)
 417   (car (cdr (or menu menu:*cur-menu*))))
 418
 419 (defun menu:menu-items (&optional menu)
 420   (car (cdr (cdr (or menu menu:*cur-menu*)))))
 421
 422 (defun menu:menu-nth-item (n &optional menu)
 423   (nth n (menu:menu-items menu)))
 424
 425 (defun menu:item-string (item)
 426   (cond ((stringp item) item)
 427         ((characterp item) (char-to-string item))
 428         ((consp item)
 429          (let ((str (cond ((stringp (car item)) (car item))
 430                           ((characterp (car item)) (char-to-string (car item)))
 431                           (t ""))))
 432            (if menu:*display-item-value*
 433                (format "%s [%s]" str (cdr item))
 434              str)))
 435         (t "")))
 436
 437 (defun menu:item-value (item)
 438   (cond ((stringp item) item)
 439         ((characterp item) (char-to-string item))
 440         ((consp item) (cdr item))
 441         (t "")))
 442
 443 (defun menu:select-submenu (submenu)
 444   "Save the current selection state, and select a new menu."
 445   (setq menu:*menu-stack*
 446         (cons (list menu:*cur-selection* menu:*cur-selections*
 447                     menu:*cur-element-no* menu:*cur-selection-no*
 448                     menu:*cur-menu* menu:*cur-element-points*)
 449               menu:*menu-stack*))
 450   (setq menu:*cur-menu* submenu))
 451
 452 (defun menu:select-saved-menu ()
 453   "Restore the most recently stored selection state."
 454   (let ((save (car menu:*menu-stack*)))
 455     (setq menu:*menu-stack*
 456           (cdr menu:*menu-stack*))
 457     (setq menu:*cur-selection*          (nth 0 save);92.10.26 by T.Saneto
 458           menu:*cur-selections*         (nth 1 save)
 459           menu:*cur-element-no*         (nth 2 save)
 460           menu:*cur-selection-no*       (nth 3 save)
 461           menu:*cur-menu*               (nth 4 save)
 462           menu:*cur-element-points*     (nth 5 save))))
 463
 464 ;;;
 465 ;;; constructors and selector for selection
 466 ;;;
 467 ;; <selection> ::= ( <pos> . <elements> )
 468 ;;      <pos> ... integer that means the absolute position in menu items
 469 ;; <elements> ::= ( <element string> ... )
 470 ;;
 471 (defsubst menu:make-selection (pos elements)
 472   (cons pos elements))
 473
 474 (defsubst menu:selection-pos (&optional selection)
 475   (car (or selection menu:*cur-selection*)))
 476
 477 (defsubst menu:selection-elements (&optional selection)
 478   (cdr (or selection menu:*cur-selection*)))
 479
 480 (defsubst menu:selection-nth-element (&optional n selection)
 481   (nth (or n menu:*cur-element-no*)
 482        (menu:selection-elements selection)))
 483
 484 (defsubst menu:selection-element-length (&optional selection)
 485   (length (menu:selection-elements selection)))
 486
 487 (defun menu:make-selections (items width)
 488   "Make selection list from ITEMS so that each selection can fit with WIDTH."
 489   (let ((headpos 0) (pos 0) (size 0)
 490         revselections revelems
 491         item-string item-width)
 492     (while items
 493       (setq item-string (menu:item-string (car items)))
 494       (setq item-width (string-width item-string))
 495       ;;; 92.9.19 by Y. Kawabe
 496       (cond ((and revelems (<= width (+ size 4 item-width)))
 497              (setq revselections
 498                    (cons (menu:make-selection headpos (nreverse revelems))
 499                          revselections))
 500              (setq revelems nil)
 501              (setq size 0)
 502              (setq headpos pos))
 503             ((or (null (cdr items)) (<= width (+ size 4 item-width)))
 504              (setq revselections
 505                    (cons
 506                     (menu:make-selection
 507                      headpos (nreverse (cons item-string revelems)))
 508                     revselections))
 509              (setq size 0)
 510              (setq headpos pos)
 511              (setq items (cdr items))
 512              (setq pos (1+ pos)))
 513             (t
 514              ;;; 92.9.19 by Y. Kawabe
 515              (setq revelems (cons item-string revelems))
 516              (setq size (+ size 4 item-width))
 517              (setq items (cdr items))
 518              (setq pos (1+ pos)))))
 519     (nreverse revselections)))
 520
 521 (defun menu:setup-selections (window-width initpos)
 522   (setq menu:*cur-selections*
 523         (menu:make-selections (menu:menu-items)
 524                               (- window-width
 525                                  ;;; 92.8.19 by K.Handa
 526                                  (string-width
 527                                   (menu:menu-prompt)))))
 528   (if initpos
 529       (let ((selections menu:*cur-selections*))
 530         (setq menu:*cur-selection-no* 0)
 531         (while (and (cdr selections)
 532                     (< (menu:selection-pos (car (cdr selections)))
 533                        initpos))
 534           (setq menu:*cur-selection-no* (1+ menu:*cur-selection-no*))
 535           (setq selections (cdr selections)))
 536         (setq menu:*cur-element-no*
 537               (- initpos (menu:selection-pos (car selections)))))))
 538
 539 ;;; utility
 540 (defun menu:check-number-range (i min max)
 541   (cond ((eq i 'max) max)
 542         ((eq i 'min) min)
 543         ((< i min) max)
 544         ((< max i) min)
 545         (t i)))
 546
 547 ;;;
 548 ;;; main part of menu
 549 ;;;
 550 (defun menu:select-from-menu (menu &optional initial position)
 551   "Display menu in minibuffer and return the selected value.
 552 If INITIAL is non-nil integer list, it behaves as menu is selected
 553 using the path specified by INITIAL in advance.
 554 If POSITION is non-nil value, return value is a pair of the selected
 555 value and the chosen path (represented by an integer list)."
 556   (let ((menu:*cur-menu* menu)
 557         (menu:*window-width* (window-width (minibuffer-window)))
 558         menu:*cur-selection* menu:*cur-selections*
 559         menu:*cur-element-no*
 560         menu:*cur-selection-no*
 561         menu:*cur-element-points*
 562         menu:*menu-stack* menu:*select-positions*
 563         (pos 0) value finished)
 564     (if initial
 565         (progn
 566           (if (numberp initial)
 567               (setq initial (list initial)))
 568           (while (cdr initial)
 569             (setq value (menu:item-value (menu:menu-nth-item (car initial))))
 570             (if (menu:menup value)
 571                 (progn
 572                   (menu:setup-selections menu:*window-width* (car initial))
 573                   (menu:select-submenu value)))
 574             (setq menu:*select-positions*
 575                   (cons (car initial) menu:*select-positions*))
 576             (setq initial (cdr initial)))
 577           (setq pos (car initial))))
 578     (while (not finished)
 579       (menu:setup-selections menu:*window-width* pos)
 580       (add-hook 'minibuffer-setup-hook 'menu:minibuffer-setup)
 581       (unwind-protect
 582           (setq pos (read-from-minibuffer "" nil minibuffer-local-menu-map
 583                                           t 'menu:*select-positions*))
 584         (remove-hook 'minibuffer-setup-hook 'menu:minibuffer-setup)
 585         (if quit-flag
 586             (setq pos nil
 587                   quit-flag nil)))
 588       (cond (pos                        ; element selected
 589              (setcar menu:*select-positions* pos)
 590              (setq value (menu:item-value (menu:menu-nth-item pos)))
 591              (if (menu:menup value)
 592                  (progn (menu:select-submenu value)
 593                         (setq pos 0))
 594                (setq finished t)))
 595             (menu:*menu-stack*          ; quit (restore menu)
 596              (if (not (car menu:*select-positions*))
 597                  (setq menu:*select-positions* (cdr menu:*select-positions*)))
 598              (setq menu:*select-positions* (cdr menu:*select-positions*))
 599              (menu:select-saved-menu))
 600             (t                          ; really quit
 601              (setq quit-flag t)
 602              (setq menu:*select-positions* nil)
 603              (setq finished t))))
 604     (if position
 605         (cons value (nreverse menu:*select-positions*))
 606       value)))
 607
 608 (defalias 'menu:minibuffer-setup 'menu:goto-selection)
 609
 610 (defun menu:goto-selection (&optional sel-no elem-no)
 611   (setq menu:*cur-selection-no*
 612         (menu:check-number-range (or sel-no menu:*cur-selection-no*)
 613                                  0 (1- (length menu:*cur-selections*))))
 614   (setq menu:*cur-selection*
 615         (nth menu:*cur-selection-no* menu:*cur-selections*))
 616   (erase-buffer)
 617   (insert (menu:menu-prompt))
 618   (let ((elements (menu:selection-elements))
 619         (i 0)
 620         revpoints)
 621     (while elements
 622       (setq revpoints (cons (+ (point) 2) revpoints))
 623       (insert (if (<= i 9) (format "  %d." i)
 624                 (format "  %c." (+ (- i 10) ?a)))
 625               (car elements))
 626       (setq elements (cdr elements)
 627             i (1+ i)))
 628     (setq menu:*cur-element-points* (nreverse revpoints)))
 629   (menu:goto-element elem-no))
 630
 631 (defun menu:goto-element (&optional elem-no)
 632   (setq menu:*cur-element-no*
 633         (menu:check-number-range (or elem-no menu:*cur-element-no*)
 634                                  0 (1- (menu:selection-element-length))))
 635   (goto-char (nth menu:*cur-element-no* menu:*cur-element-points*)))
 636
 637 (defun menu:beginning-of-selection ()
 638   (interactive)
 639   (menu:goto-element 0))
 640
 641 (defun menu:end-of-selection ()
 642   (interactive)
 643   (menu:goto-element (1- (menu:selection-element-length))))
 644
 645 (defun menu:next-selection ()
 646   (interactive)
 647   (menu:goto-selection (1+ menu:*cur-selection-no*)))
 648
 649 (defun menu:previous-selection ()
 650   (interactive)
 651   (menu:goto-selection (1- menu:*cur-selection-no*)))
 652
 653 (defun menu:next-element ()
 654   (interactive)
 655   (if (< menu:*cur-element-no* (1- (menu:selection-element-length)))
 656       (menu:goto-element (1+ menu:*cur-element-no*))
 657     (menu:goto-selection (1+ menu:*cur-selection-no*) 0)))
 658
 659 (defun menu:previous-element ()
 660   (interactive)
 661   (if (< 0 menu:*cur-element-no*)
 662       (menu:goto-element (1- menu:*cur-element-no*))
 663     (menu:goto-selection (1- menu:*cur-selection-no*) 'max)))
 664
 665 (defun menu:goto-nth-element ()
 666   (interactive)
 667   (let ((ch (event-to-character last-command-event))
 668         (elem-no-max (1- (menu:selection-element-length))))
 669     (if ch
 670         (cond
 671          ((and (<= ?0 ch) (<= ch ?9)
 672                (<= ch (+ ?0 elem-no-max)))
 673           (menu:goto-element (- ch ?0)))
 674          ((and (<= ?a ch) (<= ch ?z)
 675                (<= (+ 10 ch) (+ ?a elem-no-max)))
 676           (menu:goto-element (+ 10 (- ch ?a))))
 677          ((and (<= ?A ch) (<= ch ?Z)
 678                (<= (+ 10 ch) (+ ?A elem-no-max)))
 679           (menu:goto-element (+ 10 (- ch ?A))))))))
 680
 681 (defun menu:refresh ()
 682   (interactive)
 683   (menu:goto-selection))
 684
 685 (defun menu:select ()
 686   (interactive)
 687   (erase-buffer)
 688   (prin1 (+ (menu:selection-pos) menu:*cur-element-no*) (current-buffer))
 689   (exit-minibuffer))
 690
 691 (defun menu:quit ()
 692   (interactive)
 693   (erase-buffer)
 694   (prin1 nil (current-buffer))
 695   (exit-minibuffer))
 696
 697 ;;;----------------------------------------------------------------------
 698 ;;;
 699 ;;;  \e$B0l3g7?JQ495!G=\e(B
 700 ;;;
 701 ;;;----------------------------------------------------------------------
 702
 703
 704 ;;;
 705 ;;; \e$B$R$i$,$JJQ49\e(B
 706 ;;;
 707
 708 (defun hiragana-paragraph ()
 709   "hiragana  paragraph at or after point."
 710   (interactive )
 711   (save-excursion
 712     (forward-paragraph)
 713     (let ((end (point)))
 714       (backward-paragraph)
 715       (japanese-hiragana-region (point) end))))
 716
 717 (defun hiragana-sentence ()
 718   "hiragana  sentence at or after point."
 719   (interactive )
 720   (save-excursion
 721     (forward-sentence)
 722     (let ((end (point)))
 723       (backward-sentence)
 724       (japanese-hiragana-region (point) end))))
 725
 726 ;;;
 727 ;;; \e$B%+%?%+%JJQ49\e(B
 728 ;;;
 729
 730 (defun katakana-paragraph ()
 731   "katakana  paragraph at or after point."
 732   (interactive )
 733   (save-excursion
 734     (forward-paragraph)
 735     (let ((end (point)))
 736       (backward-paragraph)
 737       (japanese-katakana-region (point) end))))
 738
 739 (defun katakana-sentence ()
 740   "katakana  sentence at or after point."
 741   (interactive )
 742   (save-excursion
 743     (forward-sentence)
 744     (let ((end (point)))
 745       (backward-sentence)
 746       (japanese-katakana-region (point) end))))
 747
 748 ;;;
 749 ;;; \e$BH>3QJQ49\e(B
 750 ;;;
 751
 752 (defun hankaku-paragraph ()
 753   "hankaku  paragraph at or after point."
 754   (interactive )
 755   (save-excursion
 756     (forward-paragraph)
 757     (let ((end (point)))
 758       (backward-paragraph)
 759       (japanese-hankaku-region (point) end 'ascii-only))))
 760
 761 (defun hankaku-sentence ()
 762   "hankaku  sentence at or after point."
 763   (interactive )
 764   (save-excursion
 765     (forward-sentence)
 766     (let ((end (point)))
 767       (backward-sentence)
 768       (japanese-hankaku-region (point) end 'ascii-only))))
 769
 770 (defun hankaku-word (arg)
 771   (interactive "p")
 772   (let ((start (point)))
 773     (forward-word arg)
 774     (japanese-hankaku-region start (point) 'ascii-only)))
 775
 776 ;;;
 777 ;;; \e$BA43QJQ49\e(B
 778 ;;;
 779
 780 (defun zenkaku-paragraph ()
 781   "zenkaku  paragraph at or after point."
 782   (interactive )
 783   (save-excursion
 784     (forward-paragraph)
 785     (let ((end (point)))
 786       (backward-paragraph)
 787       (japanese-zenkaku-region (point) end))))
 788
 789 (defun zenkaku-sentence ()
 790   "zenkaku  sentence at or after point."
 791   (interactive )
 792   (save-excursion
 793     (forward-sentence)
 794     (let ((end (point)))
 795       (backward-sentence)
 796       (japanese-zenkaku-region (point) end))))
 797
 798 (defun zenkaku-word (arg)
 799   (interactive "p")
 800   (let ((start (point)))
 801     (forward-word arg)
 802     (japanese-zenkaku-region start (point))))
 803
 804 ;;;
 805 ;;; \e$B%m!<%^;z$+$JJQ49\e(B
 806 ;;;
 807
 808 (defun roma-kana-region (start end )
 809   (interactive "r")
 810   (its:translate-region start end nil (its:get-mode-map "roma-kana")))
 811
 812 (defun roma-kana-paragraph ()
 813   "roma-kana  paragraph at or after point."
 814   (interactive )
 815   (save-excursion
 816     (forward-paragraph)
 817     (let ((end (point)))
 818       (backward-paragraph)
 819       (roma-kana-region (point) end ))))
 820
 821 (defun roma-kana-sentence ()
 822   "roma-kana  sentence at or after point."
 823   (interactive )
 824   (save-excursion
 825     (forward-sentence)
 826     (let ((end (point)))
 827       (backward-sentence)
 828       (roma-kana-region (point) end ))))
 829
 830 (defun roma-kana-word ()
 831   "roma-kana word at or after point."
 832   (interactive)
 833   (save-excursion
 834     (re-search-backward "\\b\\w" nil t)
 835     (let ((start (point)))
 836       (re-search-forward "\\w\\b" nil t)
 837       (roma-kana-region start (point)))))
 838
 839 ;;;
 840 ;;; \e$B%m!<%^;z4A;zJQ49\e(B
 841 ;;;
 842
 843 (defun roma-kanji-region (start end)
 844   (interactive "r")
 845   (roma-kana-region start end)
 846   (save-restriction
 847     (narrow-to-region start (point))
 848     (goto-char (point-min))
 849     (replace-regexp "\\(\e$B!!\e(B\\| \\)" "")
 850     (goto-char (point-max)))
 851   (henkan-region-internal start (point)))
 852
 853 (defun roma-kanji-paragraph ()
 854   "roma-kanji  paragraph at or after point."
 855   (interactive )
 856   (save-excursion
 857     (forward-paragraph)
 858     (let ((end (point)))
 859       (backward-paragraph)
 860       (roma-kanji-region (point) end ))))
 861
 862 (defun roma-kanji-sentence ()
 863   "roma-kanji  sentence at or after point."
 864   (interactive )
 865   (save-excursion
 866     (forward-sentence)
 867     (let ((end (point)))
 868       (backward-sentence)
 869       (roma-kanji-region (point) end ))))
 870
 871 (defun roma-kanji-word ()
 872   "roma-kanji word at or after point."
 873   (interactive)
 874   (save-excursion
 875     (re-search-backward "\\b\\w" nil t)
 876     (let ((start (point)))
 877       (re-search-forward "\\w\\b" nil t)
 878       (roma-kanji-region start (point)))))
 879
 880
 881 ;;;----------------------------------------------------------------------
 882 ;;;
 883 ;;; \e$B!V$?$^$4!WF~NOJ8;zJQ497O\e(B ITS
 884 ;;;
 885 ;;;----------------------------------------------------------------------
 886
 887 (defun egg:member (elt list)
 888   (while (not (or (null list) (equal elt (car list))))
 889     (setq list (cdr list)))
 890   list)
 891
 892 ;;;
 893 ;;; Mode name --> map
 894 ;;;
 895 ;;; ITS mode name: string
 896
 897 (defvar its:*mode-alist* nil)
 898 (defvar its:*internal-mode-alist* nil)
 899
 900 (defun its:get-mode-map (name)
 901   (or (cdr (assoc name its:*mode-alist*))
 902       (cdr (assoc name its:*internal-mode-alist*))))
 903
 904 (defun its:set-mode-map (name map &optional internalp)
 905   (let ((place (assoc name
 906                       (if internalp its:*internal-mode-alist*
 907                         its:*mode-alist*))))
 908     (if place (let ((mapplace (cdr place)))
 909                 (setcar mapplace (car map))
 910                 (setcdr mapplace (cdr map)))
 911       (progn (setq place (cons name map))
 912              (if internalp
 913                  (setq its:*internal-mode-alist*
 914                        (append its:*internal-mode-alist* (list place)))
 915                (setq its:*mode-alist*
 916                      (append its:*mode-alist* (list place))))))))
 917
 918 ;;;
 919 ;;; ITS mode indicators
 920 ;;; Mode name --> indicator
 921 ;;;
 922
 923 (defun its:get-mode-indicator (name)
 924   (let ((map (its:get-mode-map name)))
 925     (if map (map-indicator map)
 926       name)))
 927
 928 (defun its:set-mode-indicator (name indicator)
 929   (let ((map (its:get-mode-map name)))
 930     (if map
 931         (map-set-indicator map indicator)
 932       (its-define-mode name indicator))))
 933
 934 ;;;
 935 ;;; ITS mode declaration
 936 ;;;
 937
 938 (defvar its:*processing-map* nil)
 939
 940 (defun its-define-mode (name &optional indicator reset supers internalp)
 941   "its-mode NAME \e$B$rDj5AA*Br$9$k!%B>$N\e(B its-mode \e$B$,A*Br$5$l$k$^$G$O\e(B
 942 its-defrule \e$B$J$I$O\e(B NAME \e$B$KBP$7$F5,B'$rDI2C$9$k!%\e(BINDICATOR \e$B$,\e(B non-nil
 943 \e$B$N;~$K$O\e(B its-mode NAME \e$B$rA*Br$9$k$H\e(B mode-line \e$B$KI=<($5$l$k!%\e(BRESET \e$B$,\e(B
 944 non-nil \e$B$N;~$K$O\e(B its-mode \e$B$NDj5A$,6u$K$J$k!%\e(BSUPERS \e$B$O>e0L$N\e(B its-mode
 945 \e$BL>$r%j%9%H$G;XDj$9$k!%\e(BINTERNALP \e$B$O\e(B mode name \e$B$rFbItL>$H$9$k!%\e(B
 946 its-defrule, its-defrule-conditional, defule-select-mode-temporally \e$B$r\e(B
 947 \e$B;2>H\e(B"
 948
 949   (if (null(its:get-mode-map name))
 950       (progn
 951         (setq its:*processing-map*
 952               (make-map nil (or indicator name) nil (mapcar 'its:get-mode-map supers)))
 953         (its:set-mode-map name its:*processing-map* internalp)
 954         )
 955     (progn (setq its:*processing-map* (its:get-mode-map name))
 956            (if indicator
 957                (map-set-indicator its:*processing-map* indicator))
 958            (if reset
 959                (progn
 960                  (map-set-state its:*processing-map* nil)
 961                  (map-set-alist its:*processing-map* nil)
 962                  ))
 963            (if supers
 964                (progn
 965                  (map-set-supers its:*processing-map* (mapcar 'its:get-mode-map supers))))))
 966   nil)
 967
 968 ;;;
 969 ;;; defrule
 970 ;;;
 971
 972 (defun its:make-standard-action (output next)
 973   "OUTPUT \e$B$H\e(B NEXT \e$B$+$i$J$k\e(B standard-action \e$B$r:n$k!%\e(B"
 974
 975   (if (and (stringp output) (string-equal output ""))
 976       (setq output nil))
 977   (if (and (stringp next)   (string-equal next   ""))
 978       (setq next nil))
 979   (cond((null output)
 980         (cond ((null next) nil)
 981               (t (list nil next))))
 982        ((consp output)
 983         ;;; alternative output
 984         (list (cons 0 output) next))
 985        ((null next) output)
 986        (t
 987         (list output next))))
 988
 989 (defun its:standard-actionp (action)
 990   "ACITION \e$B$,\e(B standard-action \e$B$G$"$k$+$I$&$+$rH=Dj$9$k!%\e(B"
 991   (or (stringp action)
 992       (and (consp action)
 993            (or (stringp (car action))
 994                (and (consp (car action))
 995                     (characterp (car (car action))))
 996                (null (car action)))
 997            (or (null (car (cdr action)))
 998                (stringp (car (cdr action)))))))
 999
1000 (defvar its:make-terminal-state 'its:default-make-terminal-state
1001   "\e$B=*C<$N>uBV$G$NI=<($r:n@.$9$k4X?t$r;XDj$9$k\e(B. \e$B4X?t$O\e(B map input
1002 action state \e$B$r0z?t$H$7$F8F$P$l!$>uBVI=<($NJ8;zNs$rJV$9!%\e(B")
1003
1004 (defun its:default-make-terminal-state (map input action state)
1005   (cond(state state)
1006        (t input)))
1007
1008 (defun its:make-terminal-state-hangul (map input action state)
1009   (cond((its:standard-actionp action) (action-output action))
1010        (t nil)))
1011
1012 (defvar its:make-non-terminal-state 'its:default-make-standard-non-terminal-state
1013   "\e$BHs=*C<$N>uBV$G$NI=<($r:n@.$9$k4X?t$r;XDj$9$k!%4X?t$O\e(B map input \e$B$r\e(B
1014 \e$B0z?t$H$7$F8F$P$l!$>uBVI=<($NJ8;zNs$rJV$9\e(B" )
1015
1016 (defun its:default-make-standard-non-terminal-state (map input)
1017   " ****"
1018   (concat
1019    (map-state-string map)
1020    (char-to-string (aref input (1- (length input))))))
1021
1022 (defun its-defrule (input output &optional next state map)
1023
1024   "INPUT \e$B$,F~NO$5$l$k$H\e(B OUTPUT \e$B$KJQ49$9$k!%\e(BNEXT \e$B$,\e(B nil \e$B$G$J$$$H$-$OJQ\e(B
1025 \e$B49$7$?8e$K\e(B NEXT \e$B$,F~NO$5$l$?$h$&$KJQ49$rB3$1$k!%\e(BINPUT\e$B$,F~NO$5$l$?;~E@\e(B
1026 \e$B$GJQ49$,3NDj$7$F$$$J$$;~$O\e(B STATE \e$B$r%U%'%s%9>e$KI=<($9$k!%JQ49$,3NDj$7\e(B
1027 \e$B$F$$$J$$;~$KI=<($9$kJ8;zNs$OJQ?t\e(B its:make-terminal-state \e$B$*$h$S\e(B \e$BJQ?t\e(B
1028 its:make-non-terminal-state \e$B$K;X<($5$l$?4X?t$K$h$C$F@8@.$5$l$k!%JQ495,\e(B
1029 \e$BB'$O\e(B MAP \e$B$G;XDj$5$l$?JQ49I=$KEPO?$5$l$k!%\e(BMAP \e$B$,\e(B nil \e$B$N>l9g$O$b$C$H$b:G\e(B
1030 \e$B6a$K\e(B its-define-mode \e$B$5$l$?JQ49I=$KEPO?$5$l$k!%$J$*\e(B OUTPUT \e$B$,\e(B nil \e$B$N>l\e(B
1031 \e$B9g$O\e(B INPUT \e$B$KBP$9$kJQ495,B'$,:o=|$5$l$k!%\e(B"
1032
1033   (its-defrule* input
1034     (its:make-standard-action output next) state
1035     (if (stringp map) map
1036       its:*processing-map*)))
1037
1038 (defmacro its-defrule-conditional (input &rest conds)
1039   "(its-defrule-conditional INPUT ((COND1 OUTPUT1) ... (CONDn OUTPUTn)))\e$B$O\e(B
1040 INPUT \e$B$,F~NO$5$l$?;~$K>r7o\e(B CONDi \e$B$r=g<!D4$Y!$@.N)$7$?;~$K$O\e(B OUTPUTi \e$B$r\e(B
1041 \e$B=PNO$9$k!%\e(B"
1042   (list 'its-defrule* input (list 'quote (cons 'cond conds))))
1043
1044 (defmacro its-defrule-conditional* (input state map &rest conds)
1045   "(its-defrule-conditional INPUT STATE MAP ((COND1 OUTPUT1) ... (CONDn
1046 OUTPUTn)))\e$B$O\e(B INPUT \e$B$,F~NO$5$l$?;~$K>uBV\e(B STATE \e$B$rI=<($7!$>r7o\e(B CONDi \e$B$r\e(B
1047 \e$B=g<!D4$Y!$@.N)$7$?;~$K$O\e(B OUTPUTi \e$B$r=PNO$9$k!%\e(B"
1048   (list 'its-defrule* input (list 'quote (cons 'cond conds)) state map))
1049
1050 (defun its-defrule-select-mode-temporally (input name)
1051   "INPUT \e$B$,F~NO$5$l$k$H\e(B temporally-mode \e$B$H$7$F\e(B NAME \e$B$,A*Br$5$l$k!%\e(B"
1052
1053   (its-defrule* input (list 'quote (list 'its:select-mode-temporally name))))
1054
1055 (defun its-defrule* (input action &optional state map)
1056   (its:resize (length input))
1057   (setq map (cond((stringp map) (its:get-mode-map map))
1058                  ((null map) its:*processing-map*)
1059                  (t map)))
1060   (its-defrule** 0 input action state map)
1061   map)
1062
1063 (defvar its:*defrule-verbose* t "nil\e$B$N>l9g\e(B, its-defrule \e$B$N7Y9p$rM^@)$9$k\e(B")
1064
1065 (defun its-defrule** (i input action state map)
1066   (cond((= (length input) i)            ;93.6.4 by T.Shingu
1067         (map-set-state
1068          map
1069          (coerce-internal-string
1070           (funcall its:make-terminal-state map input action state)))
1071         (if (and its:*defrule-verbose* (map-action map))
1072             (if action
1073                 (notify "(its-defrule \"%s\" \"%s\" ) \e$B$r:FDj5A$7$^$7$?!%\e(B"
1074                         input action)
1075               (notify "(its-defrule \"%s\" \"%s\" )\e$B$r:o=|$7$^$7$?!%\e(B"
1076                       input (map-action map))))
1077         (if (and (null action) (map-terminalp map)) nil
1078           (progn (map-set-action map action)
1079                  map)))
1080        (t
1081         (let((newmap
1082               (or (get-next-map-locally map (aref input i))
1083                   (make-map (funcall its:make-non-terminal-state
1084                                      map
1085                                      (substring input 0 (+ i (char-bytes (aref input i)))))))))
1086           (set-next-map map (aref input i)
1087                         (its-defrule** (+ i (char-bytes (aref input i))) input action state newmap)))
1088         (if (and (null (map-action map))
1089                  (map-terminalp map))
1090             nil
1091           map))))
1092
1093 ;;;
1094 ;;; map:
1095 ;;;
1096 ;;; <map-alist> ::= ( ( <char> . <map> ) ... )
1097 ;;; <topmap> ::= ( nil <indicator> <map-alist>  <supers> )
1098 ;;; <supers> ::= ( <topmap> .... )
1099 ;;; <map>    ::= ( <state> <action>    <map-alist> )
1100 ;;; <action> ::= <output> | ( <output> <next> ) ....
1101
1102 (defun make-map (&optional state action alist supers)
1103   (list state action alist supers))
1104
1105 (defun map-topmap-p (map)
1106   (null (map-state map)))
1107
1108 (defun map-supers (map)
1109   (nth 3 map))
1110
1111 (defun map-set-supers (map val)
1112   (setcar (nthcdr 3 map) val))
1113
1114 (defun map-terminalp (map)
1115   (null (map-alist map)))
1116
1117 (defun map-state (map)
1118   (nth 0 map))
1119
1120 (defun map-state-string (map)
1121   (coerce-string (map-state map)))
1122
1123 (defun map-set-state (map val)
1124   (setcar (nthcdr 0 map) val))
1125
1126 (defun map-indicator (map)
1127   (map-action map))
1128 (defun map-set-indicator (map indicator)
1129   (map-set-action map indicator))
1130
1131 (defun map-action (map)
1132   (nth 1 map))
1133 (defun map-set-action (map val)
1134   (setcar (nthcdr 1 map) val))
1135
1136 (defun map-alist (map)
1137   (nth 2 map))
1138
1139 (defun map-set-alist (map alist)
1140   (setcar (nthcdr 2 map) alist))
1141
1142 (defun get-action (map)
1143   (if (null map) nil
1144     (let ((action (map-action map)))
1145       (cond((its:standard-actionp action)
1146             action)
1147            ((symbolp action) (condition-case nil
1148                                  (funcall action)
1149                                (error nil)))
1150            (t (condition-case nil
1151                   (eval action)
1152                 (error nil)))))))
1153
1154 (defun action-output (action)
1155   (cond((stringp action) action)
1156        (t (car action))))
1157
1158 (defun action-next (action)
1159   (cond((stringp action) nil)
1160        (t (car (cdr action)))))
1161
1162 (defun get-next-map (map ch)
1163   (or (cdr (assq ch (map-alist map)))
1164       (if (map-topmap-p map)
1165           (let ((supers (map-supers map))
1166                 (result nil))
1167             (while supers
1168               (setq result (get-next-map (car supers) ch))
1169               (if result
1170                   (setq supers nil)
1171                 (setq supers (cdr supers))))
1172             result))))
1173
1174 (defun get-next-map-locally (map ch)
1175   (cdr (assq ch (map-alist map))))
1176
1177 (defun set-next-map (map ch val)
1178   (let ((place (assq ch (map-alist map))))
1179     (if place
1180         (if val
1181             (setcdr place val)
1182           (map-set-alist map (delq place (map-alist map))))
1183       (if val
1184           (map-set-alist map (cons (cons ch val)
1185                                    (map-alist map)))
1186         val))))
1187
1188 (defun its:simple-actionp (action)
1189   (stringp action))
1190
1191 (defun collect-simple-action (map)
1192   (if (map-terminalp map)
1193       (if (its:simple-actionp (map-action map))
1194           (list (map-action map))
1195         nil)
1196     (let ((alist (map-alist map))
1197           (result nil))
1198       (while alist
1199         (setq result
1200               ;;; 92.9.19 by Y. Kawabe
1201               (append (collect-simple-action (cdr (car alist)))
1202                       result))
1203         (setq alist (cdr alist)))
1204       result)))
1205
1206 ;;;----------------------------------------------------------------------
1207 ;;;
1208 ;;; Runtime translators
1209 ;;;
1210 ;;;----------------------------------------------------------------------
1211
1212 (defun its:simulate-input (i j  input map)
1213   (while (<= i j)
1214     (setq map (get-next-map map (aref input i))) ;92.12.26 by S.Tomura
1215     (setq i (+ i (char-bytes (aref input i))))) ;92.12.26 by S.Tomura
1216   map)
1217
1218 ;;; meta-flag \e$B$,\e(B on \e$B$N;~$K$O!"F~NO%3!<%I$K\e(B \200 \e$B$r\e(B or \e$B$7$?$b$N$,F~NO$5\e(B
1219 ;;; \e$B$l$k!#$3$NItJ,$N;XE&$OEl9)Bg$NCf@n\e(B \e$B5.G7$5$s$K$h$k!#\e(B
1220 ;;; pointted by nakagawa@titisa.is.titech.ac.jp Dec-11-89
1221 ;;;
1222 ;;; emacs \e$B$G$O\e(B \e$BJ8;z%3!<%I$O\e(B 0-127 \e$B$G07$&!#\e(B
1223 ;;;
1224
1225 (defvar its:*buff-s* (make-marker))
1226 (defvar its:*buff-e* (make-marker))
1227 (set-marker-insertion-type its:*buff-e* t)
1228
1229 ;;;    STATE     unread
1230 ;;; |<-s   p->|<-    e ->|
1231 ;;; s  : ch0  state0  map0
1232 ;;;  +1: ch1  state1  map1
1233 ;;; ....
1234 ;;; (point):
1235
1236 ;;; longest matching region : [s m]
1237 ;;; suspending region:        [m point]
1238 ;;; unread region          :  [point e]
1239
1240
1241 (defvar its:*maxlevel* 10)
1242 (defvar its:*maps*   (make-vector its:*maxlevel* nil))
1243 (defvar its:*actions* (make-vector its:*maxlevel* nil))
1244 (defvar its:*inputs* (make-vector its:*maxlevel* 0))
1245 (defvar its:*level* 0)
1246
1247 (defun its:resize (size)
1248   (if (<= its:*maxlevel* size)
1249       (setq its:*maxlevel* size
1250             its:*maps*    (make-vector size nil)
1251             its:*actions* (make-vector size nil)
1252             its:*inputs*  (make-vector size 0))))
1253
1254 (defun its:reset-maps (&optional init)
1255   (setq its:*level* 0)
1256   (if init
1257       (aset its:*maps* its:*level* init)))
1258
1259 (defun its:current-map () (aref its:*maps* its:*level*))
1260 (defun its:previous-map () (aref its:*maps* (max 0 (1- its:*level*))))
1261
1262 (defun its:level () its:*level*)
1263
1264 (defun its:enter-newlevel (map ch output)
1265   (setq its:*level* (1+ its:*level*))
1266   (aset its:*maps* its:*level* map)
1267   (aset its:*inputs* its:*level* ch)
1268   (aset its:*actions* its:*level* output))
1269
1270 (defvar its:*char-from-buff* nil)
1271 (defvar its:*interactive* t)
1272
1273 (defun its:reset-input ()
1274   (setq its:*char-from-buff* nil))
1275
1276 (defun its:flush-input-before-point (from)
1277   (save-excursion
1278     (while (<= from its:*level*)
1279       (its:insert-char (aref its:*inputs* from))
1280       (setq from (1+ from)))))
1281
1282 (defun its:peek-char ()
1283   (if (= (point) its:*buff-e*)
1284       (if its:*interactive*
1285           (let ((ch (egg-read-event)))
1286             (if ch
1287                 (progn
1288                   (setq unread-command-events (list (character-to-event ch)))
1289                   ch)
1290               nil))
1291         nil)
1292     (char-after (point))))
1293
1294 (defun its:read-char ()
1295   (if (= (point) its:*buff-e*)
1296       (progn
1297         (setq its:*char-from-buff* nil)
1298         (if its:*interactive*
1299             (egg-read-event)
1300           nil))
1301     (let ((ch (char-after (point))))
1302       (setq its:*char-from-buff* t)
1303       (delete-char 1)
1304       ch)))
1305
1306 (defun its:push-char (ch)
1307   (if its:*char-from-buff*
1308       (save-excursion
1309         (its:insert-char ch))
1310     (if ch (setq unread-command-events (list (character-to-event ch))))))
1311
1312 (defun its:insert-char (ch)
1313   (insert ch))
1314
1315 (defun its:ordinal-charp (ch)
1316   (and (characterp ch) (<= ch 127)
1317        (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-self-insert-command)))
1318
1319 (defun its:delete-charp (ch)
1320   (and (characterp ch) (<= ch 127)
1321        (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-backward-delete-char)))
1322
1323 (defvar egg:fence-buffer nil "Buffer fence is active in")
1324
1325 (defun fence-self-insert-command ()
1326   (interactive)
1327   (if (not (eq (current-buffer) egg:fence-buffer))
1328       nil       ;; #### This is to bandaid a deep event-handling bug
1329     (let ((ch (event-to-character last-command-event)))
1330       (cond((or (not egg:*input-mode*)
1331                 (null (get-next-map its:*current-map* ch)))
1332             (insert ch))
1333            (t
1334             (insert ch)
1335             (its:translate-region (1- (point)) (point) t))))))
1336
1337 ;;;
1338 ;;; its: completing-read system
1339 ;;;
1340
1341 (defun its:all-completions (string alist &optional pred)
1342   "A variation of all-completions.\n\
1343 Arguments are STRING, ALIST and optional PRED. ALIST must be no obarray."
1344   (let ((tail alist) (allmatches nil))
1345     (while tail
1346       (let* ((elt (car tail))
1347              (eltstring (car elt)))
1348         (setq tail (cdr tail))
1349         (if (and (stringp eltstring)
1350                  (<= (length string) (length eltstring))
1351                  ;;;(not (= (aref eltstring 0) ? ))
1352                  (string-equal string (substring eltstring 0 (length string))))
1353             (if (or (and pred
1354                          (if (eq pred 'commandp)
1355                              (commandp elt)
1356                            (funcall pred elt)))
1357                     (null pred))
1358                 (setq allmatches (cons elt allmatches))))))
1359     (nreverse allmatches)))
1360
1361 (defun its:temp-echo-area-contents (message)
1362   (let ((inhibit-quit inhibit-quit)
1363         (point-max (point-max)))
1364     (goto-char point-max)
1365     (insert message)
1366     (goto-char point-max)
1367     (setq inhibit-quit t)
1368     (sit-for 2 nil)
1369     ;;; 92.9.19 by Y. Kawabe, 92.10.30 by T.Saneto
1370     (delete-region (point) (point-max))
1371     (if quit-flag
1372         (progn
1373           (setq quit-flag nil)
1374           (setq unread-command-events (list (character-to-event ?\^G)))))))
1375
1376 (defun car-string-lessp (item1 item2)
1377   (string-lessp (car item1) (car item2)))
1378
1379 (defun its:minibuffer-completion-help ()
1380     "Display a list of possible completions of the current minibuffer contents."
1381     (interactive)
1382     (let ((completions))
1383       (message "Making completion list...")
1384       (setq completions (its:all-completions (buffer-string)
1385                                          minibuffer-completion-table
1386                                          minibuffer-completion-predicate))
1387       (if (null completions)
1388           (progn
1389             ;;; 92.9.19 by Y. Kawabe
1390             (beep)
1391             (its:temp-echo-area-contents " [No completions]"))
1392         (with-output-to-temp-buffer "*Completions*"
1393           (display-completion-list
1394            (sort completions 'car-string-lessp))))
1395       nil))
1396
1397 (defconst its:minibuffer-local-completion-map
1398   (copy-keymap minibuffer-local-completion-map))
1399 (define-key its:minibuffer-local-completion-map "?" 'its:minibuffer-completion-help)
1400 (define-key its:minibuffer-local-completion-map " " 'its:minibuffer-completion-help)
1401
1402 (defconst its:minibuffer-local-must-match-map
1403   (copy-keymap minibuffer-local-must-match-map))
1404 (define-key its:minibuffer-local-must-match-map "?" 'its:minibuffer-completion-help)
1405 (define-key its:minibuffer-local-must-match-map " " 'its:minibuffer-completion-help)
1406
1407 (fset 'si:all-completions (symbol-function 'all-completions))
1408 (fset 'si:minibuffer-completion-help (symbol-function 'minibuffer-completion-help))
1409
1410 (defun its:completing-read (prompt table &optional predicate require-match initial-input)
1411   "See completing-read"
1412   (let ((minibuffer-local-completion-map its:minibuffer-local-completion-map)
1413         (minibuffer-local-must-match-map its:minibuffer-local-must-match-map)
1414         (completion-auto-help nil))
1415     (completing-read prompt table predicate t initial-input)))
1416
1417 (defvar its:*completing-input-menu* '(menu "Which?" nil)) ;92.10.26 by T.Saneto
1418
1419 (defun its:completing-input (map)
1420   ;;;
1421   (let ((action (get-action map)))
1422     (cond((and (null action)
1423                (= (length (map-alist map)) 1))
1424           (its:completing-input (cdr (nth 0 (map-alist map)))))
1425          (t
1426           (setcar (nthcdr 2 its:*completing-input-menu*)
1427                   (map-alist map))
1428           (let ((values
1429                  (menu:select-from-menu its:*completing-input-menu*
1430                                         0 t)))
1431             (cond((consp values)
1432                   ;;; get input char from menu
1433                   )
1434                  (t
1435                   (its:completing-input map))))))))
1436
1437 (defvar its:*make-menu-from-map-result* nil)
1438
1439 (defun its:make-menu-from-map (map)
1440   (let ((its:*make-menu-from-map-result* nil))
1441     (its:make-menu-from-map* map "")
1442     (list 'menu "Which?"  (reverse its:*make-menu-from-map-result*) )))
1443
1444 (defun its:make-menu-from-map* (map string)
1445   (let ((action (get-action map)))
1446     (if action
1447         (setq its:*make-menu-from-map-result*
1448               (cons (format "%s[%s]" string (action-output action))
1449                     its:*make-menu-from-map-result*)))
1450     (let ((alist (map-alist map)))
1451       (while alist
1452         (its:make-menu-from-map*
1453          (cdr (car alist))
1454          (concat string (char-to-string (car (car alist)))))
1455         (setq alist (cdr alist))))))
1456
1457 (defvar its:*make-alist-from-map-result* nil)
1458
1459 (defun its:make-alist-from-map (map &optional string)
1460   (let ((its:*make-alist-from-map-result* nil))
1461     (its:make-alist-from-map* map (or string ""))
1462     (reverse its:*make-alist-from-map-result*)))
1463
1464 (defun its:make-alist-from-map* (map string)
1465   (let ((action (get-action map)))
1466     (if action
1467         (setq its:*make-alist-from-map-result*
1468               (cons (list string
1469                           (let ((action-output (action-output action)))
1470                             (cond((and (consp action-output)
1471                                        (characterp (car action-output)))
1472                                   (format "%s..."
1473                                   (nth (car action-output) (cdr action-output))))
1474                                  ((stringp action-output)
1475                                   action-output)
1476                                  (t
1477                                   (format "%s" action-output)))))
1478                     its:*make-alist-from-map-result*)))
1479     (let ((alist (map-alist map)))
1480       (while alist
1481         (its:make-alist-from-map*
1482          (cdr (car alist))
1483          (concat string (char-to-string (car (car alist)))))
1484         (setq alist (cdr alist))))))
1485
1486 (defvar its:*select-alternative-output-menu* '(menu "Which?" nil))
1487
1488 (defun its:select-alternative-output (action-output)
1489   ;;;; action-output : (pos item1 item2 item3 ....)
1490   (let ((point (point))
1491         (output (cdr action-output))
1492         (ch 0))
1493     (while (not (eq ch ?\^L))
1494       (insert "<" (nth (car action-output)output) ">")
1495       (setq ch (egg-read-event))
1496       (cond ((eq ch ?\^N)
1497              (setcar action-output
1498                      (mod (1+ (car action-output)) (length output))))
1499             ((eq ch ?\^P)
1500              (setcar action-output
1501                      (if (= 0 (car action-output))
1502                          (1- (length output))
1503                        (1- (car action-output)))))
1504             ((eq ch ?\^M)
1505              (setcar (nthcdr 2 its:*select-alternative-output-menu* )
1506                      output)
1507              (let ((values
1508                     (menu:select-from-menu its:*select-alternative-output-menu*
1509                                            (car action-output)
1510                                            t)))
1511                (cond((consp values)
1512                      (setcar action-output (nth 1 values))
1513                      (setq ch ?\^L)))))
1514             ((eq ch ?\^L)
1515              )
1516             (t
1517              (beep)
1518              ))
1519       (delete-region point (point)))
1520     (if its:*insert-output-string*
1521         (funcall its:*insert-output-string* (nth (car action-output) output))
1522       (insert (nth (car action-output) output)))))
1523
1524
1525
1526 ;;; translate until
1527 ;;;      interactive --> not ordinal-charp
1528 ;;; or
1529 ;;;      not interactive  --> end of input
1530
1531 (defvar its:*insert-output-string* nil)
1532 (defvar its:*display-status-string* nil)
1533
1534 (defun its:translate-region (start end its:*interactive* &optional topmap)
1535   (set-marker its:*buff-s* start)
1536   (set-marker its:*buff-e* end)
1537   (its:reset-input)
1538   (goto-char its:*buff-s*)
1539   (let ((topmap (or topmap its:*current-map*))
1540         (map nil)
1541         (ch nil)
1542         (action nil)
1543         (newmap nil)
1544         (inhibit-quit t)
1545         (its-quit-flag nil)
1546         (echo-keystrokes 0))
1547     (setq map topmap)
1548     (its:reset-maps topmap)
1549     (while (not its-quit-flag)
1550       (setq ch (its:read-char))
1551       (setq newmap (get-next-map map ch))
1552       (setq action (get-action newmap))
1553
1554       (cond
1555        ((and its:*interactive* (not its:*char-from-buff*) (characterp ch) (= ch ?\^@))
1556         (delete-region its:*buff-s* (point))
1557         (let ((i 1))
1558           (while (<= i its:*level*)
1559             (insert (aref its:*inputs* i))
1560             (setq i (1+ i))))
1561         (let ((inputs (its:completing-read "ITS:>"
1562                                            (its:make-alist-from-map topmap)
1563                                            nil
1564                                            t
1565                                            (buffer-substring its:*buff-s* (point)))))
1566           (delete-region its:*buff-s* (point))
1567           (save-excursion (insert inputs))
1568           (its:reset-maps)
1569           (setq map topmap)
1570           ))
1571        ((or (null newmap)
1572             (and (map-terminalp newmap)
1573                  (null action)))
1574
1575         (cond((and its:*interactive* (its:delete-charp ch))
1576               (delete-region its:*buff-s* (point))
1577               (cond((= its:*level* 0)
1578                     (setq its-quit-flag t))
1579                    ((= its:*level* 1)
1580                     (its:insert-char (aref its:*inputs* 1))
1581                     (setq its-quit-flag t))
1582                    (t
1583                     (its:flush-input-before-point (1+ its:*level*))
1584                     (setq its:*level* (1- its:*level*))
1585                     (setq map (its:current-map))
1586                     (if (and its:*interactive*
1587                              its:*display-status-string*)
1588                         (funcall its:*display-status-string* (map-state map))
1589                       (insert (map-state map)))
1590                     )))
1591              (t
1592               (let ((output nil))
1593                 (let ((i its:*level*) (newlevel (1+ its:*level*)))
1594                   (aset its:*inputs* newlevel ch)
1595                   (while (and (< 0 i) (null output))
1596                     (if (and (aref its:*actions* i)
1597                              (its:simulate-input (1+ i) newlevel its:*inputs* topmap))
1598                         (setq output i))
1599                     (setq i (1- i)))
1600                   (if (null output)
1601                       (let ((i its:*level*))
1602                         (while (and (< 0 i) (null output))
1603                           (if (aref its:*actions* i)
1604                               (setq output i))
1605                           (setq i (1- i)))))
1606
1607                   (cond(output
1608                         (delete-region its:*buff-s* (point))
1609                         (cond((its:standard-actionp (aref its:*actions* output))
1610                               (let ((action-output (action-output (aref its:*actions* output))))
1611                                 (if (and (not its:*interactive*)
1612                                          (consp action-output))
1613                                     (setq action-output (nth (car action-output) (cdr action-output))))
1614                                 (cond((stringp action-output)
1615                                       (if (and its:*interactive*
1616                                                its:*insert-output-string*)
1617                                           (funcall its:*insert-output-string* action-output)
1618                                         (insert action-output)))
1619                                      ((consp action-output)
1620                                       (its:select-alternative-output action-output)
1621                                       )
1622                                      (t
1623                                       (beep) (beep)
1624                                       )))
1625                               (set-marker its:*buff-s* (point))
1626                               (its:push-char ch)
1627                               (its:flush-input-before-point (1+ output))
1628                               (if (action-next (aref its:*actions* output))
1629                                   (save-excursion
1630                                     (insert (action-next (aref its:*actions* output)))))
1631                               )
1632                              ((symbolp (aref its:*actions* output))
1633                               (its:push-char ch)
1634                               (funcall (aref its:*actions* output))
1635                               (its:reset-maps its:*current-map*)
1636                               (setq topmap its:*current-map*)
1637                               (set-marker its:*buff-s* (point)))
1638                              (t
1639                               (its:push-char ch)
1640                                         ;92.10.26 by T.Saneto
1641                               (eval (aref its:*actions* output))
1642                               (its:reset-maps its:*current-map*)
1643                               (setq topmap its:*current-map*)
1644                               (set-marker its:*buff-s* (point))
1645                               ))
1646                         )
1647                        ((= 0 its:*level*)
1648                         (cond ((or (its:ordinal-charp ch)
1649                                    its:*char-from-buff*)
1650                                (its:insert-char ch))
1651                               (t (setq its-quit-flag t))))
1652
1653                        ((< 0 its:*level*)
1654                         (delete-region its:*buff-s* (point))
1655                         (its:insert-char (aref its:*inputs* 1))
1656                         (set-marker its:*buff-s* (point))
1657                         (its:push-char ch)
1658                         (its:flush-input-before-point 2)))))
1659
1660               (cond((null ch)
1661                     (setq its-quit-flag t))
1662                    ((not its-quit-flag)
1663                     (its:reset-maps)
1664                     (set-marker its:*buff-s* (point))
1665                     (setq map topmap))))))
1666
1667        ((map-terminalp newmap)
1668         (its:enter-newlevel (setq map newmap) ch action)
1669         (delete-region its:*buff-s* (point))
1670         (let ((output nil) (m nil) (i (1- its:*level*)))
1671           (while (and (< 0 i) (null output))
1672             (if (and (aref its:*actions* i)
1673                      (setq m (its:simulate-input (1+ i) its:*level* its:*inputs* topmap))
1674                      (not (map-terminalp m)))
1675                 (setq output i))
1676             (setq i (1- i)))
1677
1678           (cond((null output)
1679                 (cond ((its:standard-actionp action)
1680                        (let ((action-output (action-output action)))
1681                          (if (and (not its:*interactive*)
1682                                   (consp action-output))
1683                              (setq action-output (nth (car action-output) (cdr action-output))))
1684                          (cond((stringp action-output)
1685                                (if (and its:*interactive*
1686                                         its:*insert-output-string*)
1687                                    (funcall its:*insert-output-string* action-output)
1688                                  (insert action-output)))
1689                               ((consp action-output)
1690                                (its:select-alternative-output action-output)
1691                                )
1692                               (t
1693                                (beep) (beep)
1694                                )))
1695                        (cond((null (action-next action))
1696                              (cond ((and (= (point) its:*buff-e*)
1697                                          its:*interactive*
1698                                          (its:delete-charp (its:peek-char)))
1699                                     nil)
1700                                    (t
1701                                     (set-marker its:*buff-s* (point))
1702                                     (its:reset-maps)
1703                                     (setq map topmap)
1704                                     )))
1705                             (t
1706                              (save-excursion (insert (action-next action)))
1707                              (set-marker its:*buff-s* (point))
1708                              (its:reset-maps)
1709                              (setq map topmap))))
1710                       ((symbolp action)
1711                        (funcall action)
1712                        (its:reset-maps its:*current-map*)
1713                        (setq topmap its:*current-map*)
1714                        (setq map topmap)
1715                        (set-marker its:*buff-s* (point)))
1716                       (t
1717                        (eval action)
1718                        (its:reset-maps its:*current-map*)
1719                        (setq topmap its:*current-map*)
1720                        (setq map topmap)
1721                        (set-marker its:*buff-s* (point)))))
1722                (t
1723                 (if (and its:*interactive*
1724                          its:*display-status-string*)
1725                     (funcall its:*display-status-string* (map-state map))
1726                   (insert (map-state map)))))))
1727
1728        ((null action)
1729         (delete-region its:*buff-s* (point))
1730         (if (and its:*interactive*
1731                  its:*display-status-string*)
1732             (funcall its:*display-status-string* (map-state newmap))
1733           (insert (map-state newmap)))
1734         (its:enter-newlevel (setq map newmap)
1735                             ch action))
1736
1737        (t
1738         (its:enter-newlevel (setq map newmap) ch action)
1739         (delete-region its:*buff-s* (point))
1740         (if (and its:*interactive*
1741                  its:*display-status-string*)
1742             (funcall its:*display-status-string* (map-state map))
1743           (insert (map-state map))))))
1744
1745     (set-marker its:*buff-s* nil)
1746     (set-marker its:*buff-e* nil)
1747     (if (and its:*interactive* ch) (setq unread-command-events (list (character-to-event ch))))
1748     ))
1749
1750 ;;;----------------------------------------------------------------------
1751 ;;;
1752 ;;; ITS-map dump routine:
1753 ;;;
1754 ;;;----------------------------------------------------------------------
1755
1756 ;;;;;
1757 ;;;;; User entry: dump-its-mode-map
1758 ;;;;;
1759
1760 ;; 92.6.26 by K.Handa
1761 (defun dump-its-mode-map (name filename)
1762   "Obsolete."
1763   (interactive)
1764   (message "This function is obsolete in the current version of Mule."))
1765 ;;;
1766 ;;; EGG mode variables
1767 ;;;
1768
1769 (defvar egg:*mode-on* nil "T if egg mode is on.")
1770 (make-variable-buffer-local 'egg:*mode-on*)
1771 (set-default 'egg:*mode-on* nil)
1772
1773 (defvar egg:*input-mode* t "T if egg map is active.")
1774 (make-variable-buffer-local 'egg:*input-mode*)
1775 (set-default 'egg:*input-mode* t)
1776
1777 (defvar egg:*in-fence-mode* nil "T if in fence mode.")
1778 (make-variable-buffer-local 'egg:*in-fence-mode*)
1779 (set-default 'egg:*in-fence-mode* nil)
1780
1781 ;;(load-library "its-dump/roma-kana")         ;;;(define-its-mode "roma-kana"        " a\e$B$"\e(B")
1782 ;;(load-library "its-dump/roma-kata")         ;;;(define-its-mode "roma-kata"        " a\e$B%"\e(B")
1783 ;;(load-library "its-dump/downcase")          ;;;(define-its-mode "downcase"         " a a")
1784 ;;(load-library "its-dump/upcase")            ;;;(define-its-mode "upcase"           " a A")
1785 ;;(load-library "its-dump/zenkaku-downcase")  ;;;(define-its-mode "zenkaku-downcase" " a\e$B#a\e(B")
1786 ;;(load-library "its-dump/zenkaku-upcase")    ;;;(define-its-mode "zenkaku-upcase"   " a\e$B#A\e(B")
1787 ;; 92.3.13 by K.Handa
1788 ;; (load "its-hira")
1789 ;; (load-library "its-kata")
1790 ;; (load-library "its-hankaku")
1791 ;; (load-library "its-zenkaku")
1792
1793 (defvar its:*current-map* nil)
1794 (make-variable-buffer-local 'its:*current-map*)
1795 ;; 92.3.13 by K.Handa
1796 ;; moved to each language specific setup files (japanese.el, ...)
1797 ;; (setq-default its:*current-map* (its:get-mode-map "roma-kana"))
1798
1799 (defvar its:*previous-map* nil)
1800 (make-variable-buffer-local 'its:*previous-map*)
1801 (setq-default its:*previous-map* nil)
1802
1803 ;;;----------------------------------------------------------------------
1804 ;;;
1805 ;;; Mode line control functions;
1806 ;;;
1807 ;;;----------------------------------------------------------------------
1808
1809 (defconst mode-line-egg-mode "--")
1810 (make-variable-buffer-local 'mode-line-egg-mode)
1811
1812 (defvar   mode-line-egg-mode-in-minibuffer "--" "global variable")
1813
1814 (defun egg:find-symbol-in-tree (item tree)
1815   (if (consp tree)
1816       (or (egg:find-symbol-in-tree item (car tree))
1817           (egg:find-symbol-in-tree item (cdr tree)))
1818     (equal item tree)))
1819
1820 ;;;
1821 ;;; nemacs Ver. 3.0 \e$B$G$O\e(B Fselect_window \e$B$,JQ99$K$J$j!"\e(Bminibuffer-window
1822 ;;; \e$BB>$N\e(B window \e$B$H$N4V$G=PF~$j$,$"$k$H!"\e(Bmode-line \e$B$N99?7$r9T$J$$!"JQ?t\e(B
1823 ;;; minibuffer-window-selected \e$B$NCM$,99?7$5$l$k\e(B
1824 ;;;
1825
1826 ;;; nemacs Ver. 4 \e$B$G$O\e(B Fselect_window \e$B$,JQ99$K$J$j!$\e(Bselect-window-hook
1827 ;;; \e$B$,Dj5A$5$l$?!%$3$l$K$H$b$J$$=>Mh!$:FDj5A$7$F$$$?\e(B select-window,
1828 ;;; other-window, keyborad-quit, abort-recursive-edit, exit-minibuffer
1829 ;;; \e$B$r:o=|$7$?!%\e(B
1830
1831 (defconst display-minibuffer-mode-in-minibuffer t)
1832
1833 (defvar minibuffer-window-selected nil)
1834
1835 (defun egg:select-window-hook (old new)
1836   (if (and (eq old (minibuffer-window))
1837            (not (eq new (minibuffer-window))))
1838       (save-excursion
1839         (set-buffer (window-buffer (minibuffer-window)))
1840         (set-minibuffer-preprompt nil)
1841         (setq egg:*mode-on* (default-value 'egg:*mode-on*)
1842               egg:*input-mode* (default-value 'egg:*input-mode*)
1843               egg:*in-fence-mode* (default-value 'egg:*in-fence-mode*))))
1844   (if (eq new (minibuffer-window))
1845       (setq minibuffer-window-selected t)
1846     (setq minibuffer-window-selected nil)))
1847
1848 (defun egg:minibuffer-entry-hook ()
1849   (setq minibuffer-window-selected t))
1850
1851 (defun egg:minibuffer-exit-hook ()
1852   "Call upon exit from minibuffer"
1853   (set-minibuffer-preprompt nil)
1854   (setq minibuffer-window-selected nil)
1855   (save-excursion
1856     (set-buffer (window-buffer (minibuffer-window)))
1857     (setq egg:*mode-on* (default-value 'egg:*mode-on*)
1858           egg:*input-mode* (default-value 'egg:*input-mode*)
1859           egg:*in-fence-mode* (default-value 'egg:*in-fence-mode*))))
1860
1861
1862 ;;;
1863 ;;;
1864 ;;;
1865
1866 (defvar its:*reset-modeline-format* nil)
1867
1868
1869
1870 ;;;
1871 ;;; minibuffer \e$B$G$N%b!<%II=<($r$9$k$?$a$K\e(B nemacs 4 \e$B$GDj5A$5$l$?\e(B
1872 ;;; minibuffer-preprompt \e$B$rMxMQ$9$k!%\e(B
1873 ;;;
1874
1875 (defconst egg:minibuffer-preprompt '("[" nil "]"))
1876
1877 (defun mode-line-egg-mode-update (str)
1878   (if (eq (current-buffer) (window-buffer (minibuffer-window)))
1879       (if display-minibuffer-mode-in-minibuffer
1880           (progn
1881             (aset (nth 0 egg:minibuffer-preprompt) 0
1882                   (if its:*previous-map* ?\< ?\[))
1883             (setcar (nthcdr 1 egg:minibuffer-preprompt)
1884                     str)
1885             (aset (nth 2 egg:minibuffer-preprompt) 0
1886                   (if its:*previous-map* ?\> ?\]))
1887             (set-minibuffer-preprompt (concat
1888                                    (car egg:minibuffer-preprompt)
1889                                    (car (nthcdr 1 egg:minibuffer-preprompt))
1890                                    (car (nthcdr 2 egg:minibuffer-preprompt)))))
1891         (setq display-minibuffer-mode t
1892               mode-line-egg-mode-in-minibuffer str))
1893     (setq display-minibuffer-mode nil
1894           mode-line-egg-mode str))
1895   (redraw-modeline t))
1896
1897
1898 ;;;
1899 ;;; egg mode line display
1900 ;;;
1901
1902 (defvar alphabet-mode-indicator "aA")
1903 (defvar transparent-mode-indicator "--")
1904
1905 (defun egg:mode-line-display ()
1906   (mode-line-egg-mode-update
1907    (cond((and egg:*in-fence-mode* (not egg:*input-mode*))
1908          alphabet-mode-indicator)
1909         ((and egg:*mode-on* egg:*input-mode*)
1910          (map-indicator its:*current-map*))
1911         (t transparent-mode-indicator))))
1912
1913 (defun egg:toggle-egg-mode-on-off ()
1914   (interactive)
1915   (setq egg:*mode-on* (not egg:*mode-on*))
1916   (egg:mode-line-display))
1917
1918 (defun its:select-mode (name)
1919   (interactive (list (completing-read "ITS mode: " its:*mode-alist*)))
1920   (if (its:get-mode-map name)
1921       (progn
1922         (setq its:*current-map* (its:get-mode-map name))
1923         (egg:mode-line-display))
1924     (beep)))
1925
1926 (defvar its:*select-mode-menu* '(menu "Mode:" nil))
1927
1928 (defun its:select-mode-from-menu ()
1929   (interactive)
1930   (setcar (nthcdr 2 its:*select-mode-menu*) its:*mode-alist*)
1931   (setq its:*current-map* (menu:select-from-menu its:*select-mode-menu*))
1932   (egg:mode-line-display))
1933
1934 (defvar its:*standard-modes* nil
1935   "List of standard mode-map of EGG."
1936   ;; 92.3.13 by K.Handa
1937   ;; moved to each language specific setup files (japanese.el, ...)
1938   ;; (list (its:get-mode-map "roma-kana")
1939   ;;  (its:get-mode-map "roma-kata")
1940   ;;  (its:get-mode-map "downcase")
1941   ;;  (its:get-mode-map "upcase")
1942   ;;  (its:get-mode-map "zenkaku-downcase")
1943   ;;  (its:get-mode-map "zenkaku-upcase"))
1944   )
1945
1946 (defun its:find (map list)
1947   (let ((n 0))
1948     (while (and list (not (eq map (car list))))
1949       (setq list (cdr list)
1950             n    (1+ n)))
1951     (if list n nil)))
1952
1953 (defun its:next-mode ()
1954   (interactive)
1955   (let ((pos (its:find its:*current-map* its:*standard-modes*)))
1956     (setq its:*current-map*
1957           (nth (% (1+ pos) (length its:*standard-modes*))
1958                its:*standard-modes*))
1959     (egg:mode-line-display)))
1960
1961 (defun its:previous-mode ()
1962   (interactive)
1963   (let ((pos (its:find its:*current-map* its:*standard-modes*)))
1964     (setq its:*current-map*
1965           (nth (1- (if (= pos 0) (length its:*standard-modes*) pos))
1966                its:*standard-modes*))
1967     (egg:mode-line-display)))
1968
1969 (defun its:select-hiragana () (interactive) (its:select-mode "roma-kana"))
1970 (defun its:select-katakana () (interactive) (its:select-mode "roma-kata"))
1971 (defun its:select-downcase () (interactive) (its:select-mode "downcase"))
1972 (defun its:select-upcase   () (interactive) (its:select-mode "upcase"))
1973 (defun its:select-zenkaku-downcase () (interactive) (its:select-mode "zenkaku-downcase"))
1974 (defun its:select-zenkaku-upcase   () (interactive) (its:select-mode "zenkaku-upcase"))
1975
1976 (defun its:select-mode-temporally (name)
1977   (interactive (list (completing-read "ITS mode: " its:*mode-alist*)))
1978   (let ((map (its:get-mode-map name)))
1979     (if map
1980         (progn
1981           (if (null its:*previous-map*)
1982               (setq its:*previous-map* its:*current-map*))
1983           (setq its:*current-map*  map)
1984           (egg:mode-line-display))
1985       (beep))))
1986
1987 (defun its:select-previous-mode ()
1988   (interactive)
1989   (if (null its:*previous-map*)
1990       (beep)
1991     (setq its:*current-map* its:*previous-map*
1992           its:*previous-map* nil)
1993     (egg:mode-line-display)))
1994
1995
1996 (defun toggle-egg-mode ()
1997   (interactive)
1998   (if egg:*mode-on* (fence-toggle-egg-mode)
1999     (progn
2000       (setq egg:*mode-on* t)
2001       (egg:mode-line-display))))
2002
2003 (defun fence-toggle-egg-mode ()
2004   (interactive)
2005   (if its:*current-map*
2006       (progn
2007         (setq egg:*input-mode* (not egg:*input-mode*))
2008         (egg:mode-line-display))
2009     (beep)))
2010
2011 ;;;
2012 ;;; Changes on Global map
2013 ;;;
2014
2015 (defvar si:*global-map* (copy-keymap global-map))
2016
2017 (substitute-key-definition 'self-insert-command
2018                            'egg-self-insert-command
2019                            global-map)
2020
2021 ;; wire us into pending-delete
2022 (put 'egg-self-insert-command 'pending-delete t)
2023
2024 ;;;
2025 ;;; Currently entries C-\ and C-^ at global-map are undefined.
2026 ;;;
2027
2028 ;; Make this no-op if LEIM interface is used.
2029 (cond ((or (featurep 'egg-leim)
2030            (featurep 'egg-cwnn-leim)
2031            (featurep 'egg-kwnn-leim)) t)
2032       (t (define-key global-map "\C-\\" 'toggle-egg-mode)) )
2033 ;; #### Should hide bindings like this, too?  However, `convert-region'
2034 ;;      probably isn't going to be a LEIM feature, it's really pretty
2035 ;;      Japanese and Korean specific.
2036 (define-key global-map "\C-x " 'henkan-region)
2037
2038 ;; 92.3.16 by K.Handa
2039 ;; global-map => mule-keymap
2040 (define-key mule-keymap "m" 'its:select-mode-from-menu)
2041 (define-key mule-keymap ">" 'its:next-mode)
2042 (define-key mule-keymap "<" 'its:previous-mode)
2043 (define-key mule-keymap "h" 'its:select-hiragana)
2044 (define-key mule-keymap "k" 'its:select-katakana)
2045 (define-key mule-keymap "q" 'its:select-downcase)
2046 (define-key mule-keymap "Q" 'its:select-upcase)
2047 (define-key mule-keymap "z" 'its:select-zenkaku-downcase)
2048 (define-key mule-keymap "Z" 'its:select-zenkaku-upcase)
2049
2050 ;;;
2051 ;;; auto fill control
2052 ;;;
2053
2054 (defun egg:do-auto-fill ()
2055   (if (and auto-fill-function (not buffer-read-only)
2056            (> (current-column) fill-column))
2057       (let ((ocolumn (current-column)))
2058         (funcall auto-fill-function)
2059         (while (and (< fill-column (current-column))
2060                     (< (current-column) ocolumn))
2061           (setq ocolumn (current-column))
2062           (funcall auto-fill-function)))))
2063
2064 ;;;----------------------------------------------------------------------
2065 ;;;
2066 ;;;  Egg fence mode
2067 ;;;
2068 ;;;----------------------------------------------------------------------
2069
2070 (defvar egg:*fence-open*   "|" "*\e$B%U%'%s%9$N;OE@$r<($9J8;zNs\e(B")
2071 (defvar egg:*fence-close*  "|" "*\e$B%U%'%s%9$N=*E@$r<($9J8;zNs\e(B")
2072 (defvar egg:*fence-face* nil  "*\e$B%U%'%s%9I=<($KMQ$$$k\e(B face \e$B$^$?$O\e(B nil")
2073 (make-variable-buffer-local
2074  (defvar egg:*fence-extent* nil "\e$B%U%'%s%9I=<(MQ\e(B extent"))
2075
2076 (defvar egg:*face-alist*
2077   '(("nil" . nil)
2078     ("highlight" . highlight) ("modeline" . modeline)
2079     ("inverse" . modeline) ("underline" . underline) ("bold" . bold)
2080     ("region" . region)))
2081
2082 (defun set-egg-fence-mode-format (open close &optional face)
2083   "fence mode \e$B$NI=<(J}K!$r@_Dj$9$k!#\e(BOPEN \e$B$O%U%'%s%9$N;OE@$r<($9J8;zNs$^$?$O\e(B nil\e$B!#\e(B\n\
2084 CLOSE\e$B$O%U%'%s%9$N=*E@$r<($9J8;zNs$^$?$O\e(B nil\e$B!#\e(B\n\
2085 \e$BBh\e(B3\e$B0z?t\e(B FACE \e$B$,;XDj$5$l$F\e(B nil \e$B$G$J$1$l$P!"%U%'%s%96h4V$NI=<($K$=$l$r;H$&!#\e(B"
2086   (interactive (list (read-string "\e$B%U%'%s%93+;OJ8;zNs\e(B: ")
2087                      (read-string "\e$B%U%'%s%9=*N;J8;zNs\e(B: ")
2088                      (cdr (assoc (completing-read "\e$B%U%'%s%9I=<(B0@-\e(B: " egg:*face-alist*)
2089                                  egg:*face-alist*))))
2090
2091   (if (and (or (stringp open) (null open))
2092            (or (stringp close) (null close))
2093            (or (null face) (memq face (face-list))))
2094       (progn
2095         (setq egg:*fence-open* (or open "")
2096               egg:*fence-close* (or close "")
2097               egg:*fence-face* face)
2098         (if (extentp egg:*fence-extent*)
2099             (set-extent-property egg:*fence-extent* 'face egg:*fence-face*))
2100         t)
2101     (error "Wrong type of argument: %s %s %s" open close face)))
2102
2103 (defvar egg:*region-start* nil)
2104 (make-variable-buffer-local 'egg:*region-start*)
2105 (set-default 'egg:*region-start* nil)
2106 (defvar egg:*region-end* nil)
2107 (make-variable-buffer-local 'egg:*region-end*)
2108 (set-default 'egg:*region-end* nil)
2109 ;;(defvar egg:*global-map-backup* nil)
2110 ;;(defvar egg:*local-map-backup*  nil)
2111
2112
2113 ;;; Moved to kanji.el
2114 ;;; (defvar self-insert-after-hook nil
2115 ;;;  "Hook to run when extended self insertion command exits. Should take
2116 ;;; two arguments START and END correspoding to character position.")
2117
2118 (defvar egg:*self-insert-non-undo-count* 0
2119   "counter to hold repetition of egg-self-insert-command.")
2120
2121 (defun egg-self-insert-command (arg)
2122   (interactive "p")
2123   (if (and (not buffer-read-only)
2124            egg:*mode-on* egg:*input-mode*
2125            (not egg:*in-fence-mode*) ;;; inhibit recursive fence mode
2126            (not (= (event-to-character last-command-event) ? )))
2127       (egg:enter-fence-mode-and-self-insert)
2128     (progn
2129       ;; treat continuous 20 self insert as a single undo chunk.
2130       ;; `20' is a magic number copied from keyboard.c
2131       (if (or                           ;92.12.20 by T.Enami
2132            (not (eq last-command 'egg-self-insert-command))
2133            (>= egg:*self-insert-non-undo-count* 20))
2134           (setq egg:*self-insert-non-undo-count* 1)
2135         (cancel-undo-boundary)
2136         (setq egg:*self-insert-non-undo-count*
2137               (1+ egg:*self-insert-non-undo-count*)))
2138       (self-insert-command arg)
2139       (if egg-insert-after-hook
2140           (run-hooks 'egg-insert-after-hook))
2141       (if self-insert-after-hook
2142           (if (<= 1 arg)
2143               (funcall self-insert-after-hook
2144                        (- (point) arg) (point)))
2145         (if (= (event-to-character last-command-event) ? ) (egg:do-auto-fill))))))
2146
2147 ;;
2148 ;; \e$BA03NDjJQ49=hM}4X?t\e(B
2149 ;;
2150 (defvar egg:*fence-open-backup* nil)
2151 (defvar egg:*fence-close-backup* nil)
2152 (defvar egg:*fence-face-backup* nil)
2153
2154 (defconst egg:*fence-open-in-cont* "+" "*\e$BA03NDj>uBV$G$N\e(B *fence-open*")
2155 (defconst egg:*fence-close-in-cont* t "*\e$BA03NDj>uBV$G$N\e(B *fence-close*")
2156 (defconst egg:*fence-face-in-cont* t
2157   "*\e$BA03NDj>uBV$G$N\e(B *fence-face*")
2158
2159 (defun set-egg-fence-mode-format-in-cont (open close face)
2160   "\e$BA03NDj>uBV$G$N\e(B fence mode \e$B$NI=<(J}K!$r@_Dj$9$k!#\e(BOPEN \e$B$O%U%'%s%9$N;OE@$r<($9J8\e(B
2161 \e$B;zNs!"\e(Bt \e$B$^$?$O\e(B nil\e$B!#\e(B\n\
2162 CLOSE\e$B$O%U%'%s%9$N=*E@$r<($9J8;zNs!"\e(Bt \e$B$^$?$O\e(B nil\e$B!#\e(B\n\
2163 FACE \e$B$O\e(B nil \e$B$G$J$1$l$P!"%U%'%s%96h4V$NI=<($K$=$l$r;H$&!#\e(B\n\
2164 \e$B$=$l$>$l$NCM$,\e(B t \e$B$N>l9g!"DL>o$N\e(B egg:*fence-open* \e$BEy$NCM$r0z$-7Q$0!#\e(B"
2165   (interactive (list (read-string "\e$B%U%'%s%93+;OJ8;zNs\e(B: ")
2166                      (read-string "\e$B%U%'%s%9=*N;J8;zNs\e(B: ")
2167                      (cdr (assoc (completing-read "\e$B%U%'%s%9I=<(B0@-\e(B: " egg:*face
2168 -alist*)
2169                                  egg:*face-alist*))))
2170
2171   (if (and (or (stringp open) (eq open t) (null open))
2172            (or (stringp close) (eq close t) (null close))
2173            (or (null face) (eq face t) (memq face (face-list))))
2174       (progn
2175         (setq egg:*fence-open-in-cont* (or open "")
2176               egg:*fence-close-in-cont* (or close "")
2177               egg:*fence-face-in-cont* face)
2178         (if (extentp egg:*fence-extent*)
2179             (set-extent-property egg:*fence-extent* 'face egg:*fence-face*))
2180         t)
2181     (error "Wrong type of argument: %s %s %s" open close face)))
2182
2183 (defvar *in-cont-flag* nil
2184  "\e$BD>A0$KJQ49$7$?D>8e$NF~NO$+$I$&$+$r<($9!#\e(B")
2185
2186 (defvar *in-cont-backup-flag* nil)
2187
2188 (defun egg:check-fence-in-cont ()
2189   (if *in-cont-flag*
2190       (progn
2191         (setq *in-cont-backup-flag* t)
2192         (setq egg:*fence-open-backup* egg:*fence-open*)
2193         (setq egg:*fence-close-backup* egg:*fence-close*)
2194         (setq egg:*fence-face-backup* egg:*fence-face*)
2195         (or (eq egg:*fence-open-in-cont* t)
2196             (setq egg:*fence-open* egg:*fence-open-in-cont*))
2197         (or (eq egg:*fence-close-in-cont* t)
2198             (setq egg:*fence-close* egg:*fence-close-in-cont*))
2199         (or (eq egg:*fence-face-in-cont* t)
2200             (setq egg:*fence-face* egg:*fence-face-in-cont*)))))
2201
2202 (defun egg:restore-fence-in-cont ()
2203   "Restore egg:*fence-open* and egg:*fence-close*"
2204   (if *in-cont-backup-flag*
2205       (progn
2206         (setq egg:*fence-open* egg:*fence-open-backup*)
2207         (setq egg:*fence-close* egg:*fence-close-backup*)
2208         (setq egg:*fence-face* egg:*fence-face-backup*)))
2209   (setq *in-cont-backup-flag* nil)
2210   )
2211
2212 (defun egg:enter-fence-mode-and-self-insert ()
2213   (setq *in-cont-flag*
2214         (memq last-command '(henkan-kakutei henkan-kakutei-and-self-insert)))
2215   (enter-fence-mode)
2216   (setq unread-command-events (list last-command-event)))
2217
2218 (defun egg:fence-face-on ()
2219   (if egg:*fence-face*
2220       (progn
2221         (if (extentp egg:*fence-extent*)
2222             (set-extent-endpoints egg:*fence-extent* egg:*region-start* egg:*region-end*)
2223           (setq egg:*fence-extent* (make-extent egg:*region-start* egg:*region-end*))
2224           (set-extent-property egg:*fence-extent* 'start-open nil)
2225           (set-extent-property egg:*fence-extent* 'end-open nil)
2226           (set-extent-property egg:*fence-extent* 'detachable nil))
2227         (set-extent-face egg:*fence-extent* egg:*fence-face*))))
2228
2229 (defun egg:fence-face-off ()
2230   (and egg:*fence-face*
2231        (extentp egg:*fence-extent*)
2232        (detach-extent egg:*fence-extent*) ))
2233
2234 (defun enter-fence-mode ()
2235
2236   ;; XEmacs change:
2237 ;  (buffer-disable-undo (current-buffer))
2238   (suspend-undo)
2239   (setq egg:*in-fence-mode* t
2240         egg:fence-buffer (current-buffer))
2241   (egg:mode-line-display)
2242   ;;;(setq egg:*global-map-backup* (current-global-map))
2243   ;;(setq egg:*local-map-backup*  (current-local-map))
2244   ;;;(use-global-map fence-mode-map)
2245   ;;;(use-local-map nil)
2246   ;;(use-local-map fence-mode-map)
2247   (egg:check-fence-in-cont)            ; for Wnn6
2248   (insert egg:*fence-open*)
2249   (or (markerp egg:*region-start*) (setq egg:*region-start* (make-marker)))
2250   (set-marker egg:*region-start* (point))
2251   (insert egg:*fence-close*)
2252   (or (markerp egg:*region-end*) (set-marker-insertion-type (setq egg:*region-end* (make-marker)) t))
2253   (set-marker egg:*region-end* egg:*region-start*)
2254   (egg:fence-face-on)
2255   (goto-char egg:*region-start*)
2256   ;;(add-hook 'post-command-hook 'fence-post-command-hook)
2257   )
2258
2259 (defun henkan-fence-region-or-single-space ()
2260   (interactive)
2261   (if egg:*input-mode*
2262       (henkan-fence-region)
2263     (insert ? )))
2264
2265 (defvar egg:*henkan-fence-mode* nil)
2266
2267 (defun henkan-fence-region ()
2268   (interactive)
2269   (setq egg:*henkan-fence-mode* t)
2270   (egg:fence-face-off)
2271   (henkan-region-internal egg:*region-start* egg:*region-end* ))
2272
2273 (defun fence-katakana  ()
2274   (interactive)
2275   (japanese-katakana-region egg:*region-start* egg:*region-end*))
2276
2277 (defun fence-hiragana  ()
2278   (interactive)
2279   (japanese-hiragana-region egg:*region-start* egg:*region-end*))
2280
2281 (defun fence-hankaku  ()
2282   (interactive)
2283   (japanese-hankaku-region egg:*region-start* egg:*region-end* 'ascii-only))
2284
2285 (defun fence-zenkaku  ()
2286   (interactive)
2287   (japanese-zenkaku-region egg:*region-start* egg:*region-end*))
2288
2289 (defun fence-backward-char ()
2290   (interactive)
2291   (if (< egg:*region-start* (point))
2292       (backward-char)
2293     (beep)))
2294
2295 (defun fence-forward-char ()
2296   (interactive)
2297   (if (< (point) egg:*region-end*)
2298       (forward-char)
2299     (beep)))
2300
2301 (defun fence-beginning-of-line ()
2302   (interactive)
2303   (goto-char egg:*region-start*))
2304
2305 (defun fence-end-of-line ()
2306   (interactive)
2307   (goto-char egg:*region-end*))
2308
2309 (defun fence-transpose-chars (arg)
2310   (interactive "P")
2311   (if (and (< egg:*region-start* (point))
2312            (< (point) egg:*region-end*))
2313       (transpose-chars arg)
2314     (beep)))
2315
2316 (defun egg:exit-if-empty-region ()
2317   (if (= egg:*region-start* egg:*region-end*)
2318       (fence-exit-internal)))
2319
2320 (defun fence-delete-char ()
2321   (interactive)
2322   (if (< (point) egg:*region-end*)
2323       (progn
2324         (delete-char 1)
2325         (egg:exit-if-empty-region))
2326     (beep)))
2327
2328 (defun fence-backward-delete-char ()
2329   (interactive)
2330   (if (< egg:*region-start* (point))
2331       (progn
2332         (delete-char -1)
2333         (egg:exit-if-empty-region))
2334     (beep)))
2335
2336 (defun fence-kill-line ()
2337   (interactive)
2338   (delete-region (point) egg:*region-end*)
2339   (egg:exit-if-empty-region))
2340
2341 (defun fence-exit-mode ()
2342   (interactive)
2343   (fence-exit-internal))
2344
2345 (defun fence-exit-internal ()
2346   (egg:fence-face-off)
2347   (setq egg:*in-fence-mode* nil)
2348   (let ((kakutei-string (buffer-substring
2349                          egg:*region-start* egg:*region-end*)))
2350     (delete-region (- egg:*region-start* (length egg:*fence-open*))
2351                    egg:*region-start*)
2352     (delete-region egg:*region-start* egg:*region-end*)
2353     (delete-region egg:*region-end*
2354                    (+ egg:*region-end* (length egg:*fence-close*)))
2355     (goto-char egg:*region-start*)
2356     (resume-undo-list)
2357     (insert kakutei-string))
2358   (if its:*previous-map*
2359       (setq its:*current-map* its:*previous-map*
2360             its:*previous-map* nil))
2361   (egg:quit-egg-mode))
2362
2363 ;; jhod: This seems bogus to me, as it should be called either after each
2364 ;; egg-self-insert, or after accepting input, but not both. Otherwise, I can't
2365 ;; really think of a use for it.
2366 (defvar egg-insert-after-hook nil
2367   "Hook to run when egg inserts a character in the buffer")
2368
2369 (make-variable-buffer-local 'egg-insert-after-hook)
2370
2371 (defvar egg-exit-hook nil
2372   "Hook to run when egg exits. Should take two arguments START and END
2373 correspoding to character position.")
2374
2375 (defun egg:quit-egg-mode ()
2376   ;;;(use-global-map egg:*global-map-backup*)
2377   ;;(use-local-map egg:*local-map-backup*)
2378   ;;(remove-hook 'post-command-hook 'fence-post-command-hook)
2379   (egg:mode-line-display)
2380   (if overwrite-mode
2381       (let ((str (buffer-substring egg:*region-end* egg:*region-start*)))
2382         (delete-text-in-column nil (+ (current-column) (string-width str)))))
2383   (egg:restore-fence-in-cont)               ; for Wnn6
2384   (setq egg:*henkan-fence-mode* nil)
2385   (if self-insert-after-hook
2386       (funcall self-insert-after-hook egg:*region-start* egg:*region-end*)
2387     (if egg-exit-hook
2388         (funcall egg-exit-hook egg:*region-start* egg:*region-end*)
2389       (if (not (= egg:*region-start* egg:*region-end*))
2390           (egg:do-auto-fill))))
2391   (set-marker egg:*region-start* nil)
2392   (set-marker egg:*region-end*   nil)
2393   ;; XEmacs change:
2394 ;  (buffer-enable-undo (current-buffer))
2395   (if egg-insert-after-hook
2396       (run-hooks 'egg-insert-after-hook))
2397   )
2398
2399 (defun fence-cancel-input ()
2400   "Cancel all fence operations in the current buffer"
2401   (interactive)
2402   (fence-kill-operation))
2403
2404 (defun fence-kill-operation ()
2405   "Internal method to remove fences"
2406   (delete-region egg:*region-start* egg:*region-end*)
2407   (fence-exit-internal))
2408
2409 ;;(defun fence-post-command-hook ()
2410 ;;  ;; For use as the value of `post-command-hook' when fence is active.
2411 ;;  ;; If we got out of the region specified by the fence,
2412 ;;  ;; kill the fence before that command is executed.
2413 ;;  ;;
2414 ;;  (cond ((not (eq (current-buffer) egg:fence-buffer))
2415 ;;       ;; If the buffer (likely meaning "frame") has changed, bail.
2416 ;;       ;; This can also happen if a proc filter has popped up another
2417 ;;       ;; buffer, which is arguably a bad thing for it to have done,
2418 ;;       ;; but the way in which egg would have hosed you in that
2419 ;;       ;; case is unarguably even worse.
2420 ;;       (save-excursion
2421 ;;         (set-buffer egg:fence-buffer)
2422 ;;         (its:reset-input)
2423 ;;         (fence-kill-operation)))
2424 ;;      ((or (< (point) egg:*region-start*)
2425 ;;           (> (point) egg:*region-end*))
2426 ;;       (save-excursion
2427 ;;         (its:reset-input)
2428 ;;         (fence-kill-operation)))))
2429
2430 (defun egg-lang-switch-callback ()
2431   "Do whatever processing is necessary when the language-environment changes."
2432   (if egg:*in-fence-mode*
2433       (progn
2434         (its:reset-input)
2435         (fence-kill-operation)))
2436   (let ((func (get current-language-environment 'set-egg-environ)))
2437     (if (not (null func))
2438       (funcall func)))
2439   (egg:mode-line-display))
2440
2441 (defun fence-mode-help-command ()
2442   "Display fence mode help"
2443   (interactive "_")
2444   (let ((w (selected-window)))
2445     (describe-function 'egg-mode)
2446     (ding)
2447     (select-window w)))
2448
2449 (defvar fence-mode-map (make-sparse-keymap))
2450 (substitute-key-definition 'egg-self-insert-command
2451                            'fence-self-insert-command
2452                            fence-mode-map global-map)
2453 (set-keymap-default-binding fence-mode-map 'undefined)
2454
2455 (define-key fence-mode-map "\eh"  'fence-hiragana)
2456 (define-key fence-mode-map "\ek"  'fence-katakana)
2457 (define-key fence-mode-map "\e<"  'fence-hankaku)
2458 (define-key fence-mode-map "\e>"  'fence-zenkaku)
2459 (define-key fence-mode-map "\e\C-h" 'its:select-hiragana)
2460 (define-key fence-mode-map "\e\C-k" 'its:select-katakana)
2461 (define-key fence-mode-map "\eq"    'its:select-downcase)
2462 (define-key fence-mode-map "\eQ"    'its:select-upcase)
2463 (define-key fence-mode-map "\ez"    'its:select-zenkaku-downcase)
2464 (define-key fence-mode-map "\eZ"    'its:select-zenkaku-upcase)
2465 (define-key fence-mode-map " "    'henkan-fence-region-or-single-space)
2466 (define-key fence-mode-map "\C-@" 'henkan-fence-region)
2467 (define-key fence-mode-map [(control \ )] 'henkan-fence-region)
2468 (define-key fence-mode-map "\C-a" 'fence-beginning-of-line)
2469 (define-key fence-mode-map "\C-b" 'fence-backward-char)
2470 (define-key fence-mode-map "\C-c" 'fence-cancel-input)
2471 (define-key fence-mode-map "\C-d" 'fence-delete-char)
2472 (define-key fence-mode-map "\C-e" 'fence-end-of-line)
2473 (define-key fence-mode-map "\C-f" 'fence-forward-char)
2474 (define-key fence-mode-map "\C-g" 'fence-cancel-input)
2475 (define-key fence-mode-map "\C-h" 'fence-mode-help-command)
2476 (define-key fence-mode-map "\C-k" 'fence-kill-line)
2477 (define-key fence-mode-map "\C-l" 'fence-exit-mode)
2478 (define-key fence-mode-map "\C-m" 'fence-exit-mode)  ;;; RET
2479 (define-key fence-mode-map "\C-q" 'its:select-previous-mode)
2480 (define-key fence-mode-map "\C-t" 'fence-transpose-chars)
2481 (define-key fence-mode-map "\C-w" 'henkan-fence-region)
2482 (define-key fence-mode-map "\C-z" 'eval-expression)
2483 (define-key fence-mode-map "\C-\\" 'fence-toggle-egg-mode)
2484 (define-key fence-mode-map "\C-_" 'jis-code-input)
2485 (define-key fence-mode-map "\177" 'fence-backward-delete-char)
2486 (define-key fence-mode-map [backspace] 'fence-backward-delete-char)
2487 (define-key fence-mode-map [clear]     'fence-cancel-input)
2488 (define-key fence-mode-map [delete]    'fence-backward-delete-char)
2489 (define-key fence-mode-map [help]      'fence-mode-help-command)
2490 (define-key fence-mode-map [kp-enter]  'fence-exit-mode)
2491 (define-key fence-mode-map [kp-left]   'fence-backward-char)
2492 (define-key fence-mode-map [kp-right]  'fence-forward-char)
2493 (define-key fence-mode-map [left]      'fence-backward-char)
2494 (define-key fence-mode-map [return]    'fence-exit-mode)
2495 (define-key fence-mode-map [right]     'fence-forward-char)
2496
2497 (unless (assq 'egg:*in-fence-mode* minor-mode-map-alist)
2498   (setq minor-mode-map-alist
2499         (cons (cons 'egg:*in-fence-mode* fence-mode-map)
2500               minor-mode-map-alist)))
2501
2502 ;;;----------------------------------------------------------------------
2503 ;;;
2504 ;;; Read hiragana from minibuffer
2505 ;;;
2506 ;;;----------------------------------------------------------------------
2507
2508 (defvar egg:*minibuffer-local-hiragana-map* (copy-keymap minibuffer-local-map))
2509
2510 (substitute-key-definition 'egg-self-insert-command
2511                            'fence-self-insert-command
2512                            egg:*minibuffer-local-hiragana-map*
2513                            global-map)
2514
2515 (defun read-hiragana-string (prompt &optional initial-input)
2516   (let ((egg:fence-buffer (window-buffer (minibuffer-window)))
2517         ;;(minibuffer-exit-hook
2518         ;; (append minibuffer-exit-hook
2519         ;;       '((lambda () (use-local-map minibuffer-local-map)))))
2520         )
2521     (save-excursion
2522       (set-buffer egg:fence-buffer)
2523       (setq egg:*input-mode* t
2524             egg:*mode-on*    t
2525             its:*current-map* (its:get-mode-map "roma-kana"))
2526       (mode-line-egg-mode-update (its:get-mode-indicator "roma-kana")))
2527     (read-from-minibuffer prompt initial-input
2528                           egg:*minibuffer-local-hiragana-map*)))
2529
2530 (defun read-kanji-string (prompt &optional initial-input)
2531   (save-excursion
2532     (let ((minibuff (window-buffer (minibuffer-window))))
2533       (set-buffer minibuff)
2534       (setq egg:*input-mode* t
2535             egg:*mode-on*    t
2536             its:*current-map* (its:get-mode-map "roma-kana"))
2537       (mode-line-egg-mode-update (its:get-mode-indicator "roma-kana"))))
2538   (read-from-minibuffer prompt initial-input))
2539
2540 (defconst isearch:read-kanji-string 'read-kanji-string)
2541
2542 ;;; \e$B5-9fF~NO\e(B
2543
2544 (defvar special-symbol-input-point nil)
2545
2546 (defun special-symbol-input ()
2547   (interactive)
2548   (require 'egg-jsymbol)
2549   ;; 92.7.8 by Y.Kawabe
2550   (let ((item (menu:select-from-menu
2551                *symbol-input-menu* special-symbol-input-point t))
2552         (code t))
2553     (and (listp item)
2554          (setq code (car item) special-symbol-input-point (cdr item)))
2555     ;; end of patch
2556     (cond((stringp code) (insert code))
2557          ((consp code) (eval code))
2558          )))
2559
2560
2561 ;; (autoload 'busyu-input "egg-busyu" nil t)
2562 ;; (autoload 'kakusuu-input "egg-busyu" nil t)
2563
2564 (defun egg-mode ()
2565   "Install and start the egg input method.
2566 The keys that are defined for the fence mode (which is the translation
2567 part of egg) are:\\{fence-mode-map}"
2568   (interactive)
2569   (define-key global-map "\C-^"  'special-symbol-input)
2570   (if (not (egg:find-symbol-in-tree 'mode-line-egg-mode modeline-format))
2571       (setq-default
2572        modeline-format
2573        (cons (list 'display-minibuffer-mode-in-minibuffer
2574                  ;;; minibuffer mode in minibuffer
2575                    (list
2576                     (list 'its:*previous-map* "<" "[")
2577                     'mode-line-egg-mode
2578                     (list 'its:*previous-map* ">" "]")
2579                     )
2580                        ;;;; minibuffer mode in mode line
2581                    (list
2582                     (list 'minibuffer-window-selected
2583                           (list 'display-minibuffer-mode
2584                                 "m"
2585                                 " ")
2586                           " ")
2587                     (list 'its:*previous-map* "<" "[")
2588                     (list 'minibuffer-window-selected
2589                           (list 'display-minibuffer-mode
2590                                 'mode-line-egg-mode-in-minibuffer
2591                                 'mode-line-egg-mode)
2592                           'mode-line-egg-mode)
2593                     (list 'its:*previous-map* ">" "]")
2594                     ))
2595              modeline-format)))
2596   ;; put us into the modeline of all existing buffers
2597   (mapc (lambda (buf)
2598           (save-excursion
2599             (set-buffer buf)
2600             (if (not (egg:find-symbol-in-tree 'mode-line-egg-mode modeline-format))
2601                 (setq modeline-format
2602                       (cons (list 'display-minibuffer-mode-in-minibuffer
2603                  ;;; minibuffer mode in minibuffer
2604                                   (list
2605                                    (list 'its:*previous-map* "<" "[")
2606                                    'mode-line-egg-mode
2607                                    (list 'its:*previous-map* ">" "]")
2608                                    )
2609                        ;;;; minibuffer mode in mode line
2610                                   (list
2611                                    (list 'minibuffer-window-selected
2612                                          (list 'display-minibuffer-mode
2613                                                "m"
2614                                                " ")
2615                                          " ")
2616                                    (list 'its:*previous-map* "<" "[")
2617                                    (list 'minibuffer-window-selected
2618                                          (list 'display-minibuffer-mode
2619                                                'mode-line-egg-mode-in-minibuffer
2620                                                'mode-line-egg-mode)
2621                                          'mode-line-egg-mode)
2622                                    (list 'its:*previous-map* ">" "]")
2623                                    ))
2624                             modeline-format)))))
2625         (buffer-list))
2626   (if (boundp 'select-window-hook)
2627       (add-hook 'select-window-hook 'egg:select-window-hook)
2628     (add-hook 'minibuffer-exit-hook 'egg:minibuffer-exit-hook)
2629     (add-hook 'minibuffer-entry-hook 'egg:minibuffer-entry-hook))
2630   (mode-line-egg-mode-update mode-line-egg-mode)
2631   (if its:*reset-modeline-format*
2632       (setq-default modeline-format
2633                     (cdr modeline-format)))
2634
2635   ;; if set-lang-environment has already been called,
2636   ;; call egg-lang-switch-callback
2637   (if (not (null current-language-environment))
2638       (egg-lang-switch-callback))
2639   )
2640
2641 (provide 'egg)
2642
2643 ;;; egg.el ends here