egg.el

   1 ;;; egg.el --- EGG Input Method Architecture
   2
   3 ;; Copyright (C) 1997, 1998 Mule Project, Powered by Electrotechnical
   4 ;; Laboratory, JAPAN.
   5 ;; Project Leader: Satoru Tomura <tomura@etl.go.jp>
   6
   7 ;; Author: NIIBE Yutaka <gniibe@mri.co.jp>
   8 ;;         KATAYAMA Yoshio <kate@pfu.co.jp>
   9 ;; Maintainer: NIIBE Yutaka <gniibe@mri.co.jp>
  10 ;; Keywords: mule, multilingual, input method
  11
  12 ;; This file is part of EGG.
  13
  14 ;; EGG is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; EGG is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32 (require 'egg-edep)
  33
  34 (defvar egg-mode-preference t
  35   "Non-nil if modefull.")
  36
  37 (defvar egg-default-language)
  38 (defvar egg-last-method-name)
  39 (make-variable-buffer-local 'egg-last-method-name)
  40
  41 ;;;###autoload
  42 (defun egg-mode (&rest arg)
  43   "Toggle EGG  mode.
  44 \\[describe-bindings]
  45 "
  46   (interactive "P")
  47   (if (null arg)
  48       ;; Turn off
  49       (progn
  50         (cond
  51          ((its-in-fence-p)
  52           (its-exit-mode))
  53          ((egg-get-bunsetsu-info (point))
  54           (egg-exit-conversion)))
  55         (setq describe-current-input-method-function nil)
  56         (setq current-input-method nil)
  57         (use-local-map (keymap-parent (current-local-map)))
  58         (remove-hook 'input-method-activate-hook 'its-set-mode-line-title t)
  59         (force-mode-line-update))
  60     ;; Turn on
  61     (if (null (string= (car arg) egg-last-method-name))
  62         (progn
  63           (funcall (nth 1 arg))
  64           (setq egg-default-language its-current-language)))
  65     (setq egg-last-method-name (car arg))
  66     (use-local-map (if egg-mode-preference
  67                        (egg-modefull-map)
  68                      (egg-modeless-map)))
  69     (setq inactivate-current-input-method-function 'egg-mode)
  70     (setq describe-current-input-method-function 'egg-help)
  71     (make-local-hook 'input-method-activate-hook)
  72     (add-hook 'input-method-activate-hook 'its-set-mode-line-title nil t)))
  73
  74 (defun egg-modefull-map ()
  75   "Generate modefull keymap for EGG mode."
  76   (let ((map (make-sparse-keymap))
  77         (i 33))
  78     ;; BAD BAD BAD it should be UNDO
  79     ;;    (define-key map "\C-_" 'egg-jis-code-input)
  80     (while (< i 127)
  81       (define-key map (vector i) 'egg-self-insert-char)
  82       (setq i (1+ i)))
  83     (its-define-select-keys map)
  84     (set-keymap-parent map (current-local-map))
  85     map))
  86
  87 (defun egg-modeless-map ()
  88   "Generate modeless keymap for EGG mode."
  89   (let ((map (make-sparse-keymap)))
  90     (define-key map " " 'mlh-space-bar-backward-henkan)
  91     (define-key map "\C-_" 'egg-jis-code-input)
  92     (set-keymap-parent map (current-local-map))
  93     map))
  94
  95 (defun egg-self-insert-char ()
  96   (interactive)
  97   (its-start last-command-char))
  98 \f
  99 (defvar egg-mark-list nil)
 100 (defvar egg-suppress-marking nil)
 101
 102 (defun egg-set-face (beg eng face &optional object)
 103   (put face 'face face)
 104   (add-text-properties beg eng
 105                        (list 'category face
 106                              'egg-face t
 107                              'modification-hooks '(egg-mark-modification))
 108                        object))
 109
 110 (defun egg-mark-modification (beg end)
 111   (if (and (null egg-suppress-marking)
 112            (or (get-text-property beg 'egg-face)
 113                (setq beg (next-single-property-change beg 'egg-face)))
 114            (or (get-text-property (1- end) 'egg-face)
 115                (setq end (previous-single-property-change end 'egg-face)))
 116            (< beg end))
 117       (let ((list egg-mark-list)
 118             (found 0)
 119             pair mb me b e)
 120         (add-hook 'post-command-hook 'egg-redraw-face t)
 121         (setq list egg-mark-list)
 122         (while (and list (< found 2))
 123           (setq pair (car list)
 124                 list (cdr list)
 125                 mb (car pair)
 126                 me (cdr pair)
 127                 b (marker-position mb)
 128                 e (marker-position me))
 129           (cond
 130            ;; no overwrapping -- SKIP
 131            ((or (null (eq (marker-buffer mb) (current-buffer)))
 132                 (or (> beg e) (< end b))))
 133            ;; completely included
 134            ((and (>= beg b) (<= end e))
 135             (setq found 3))
 136            ;; partially overwrapping
 137            (t
 138             (set-marker mb nil)
 139             (set-marker me nil)
 140             (setq egg-mark-list (delete pair egg-mark-list)
 141                   beg (min beg b)
 142                   end (max end e)
 143                   found (1+ found)))))
 144         (if (< found 3)
 145             (progn
 146               (setq b (make-marker)
 147                     e (make-marker)
 148                     egg-mark-list (cons (cons b e) egg-mark-list))
 149               (set-marker b beg)
 150               (set-marker e end))))))
 151
 152 (defun egg-redraw-face ()
 153   (let ((inhibit-read-only t)
 154         (inhibit-point-motion-hooks t)
 155         (egg-suppress-marking t)
 156         (list egg-mark-list)
 157         (org-buffer (current-buffer))
 158         (org-point (point))
 159         mb me b e p)
 160     (setq egg-mark-list nil)
 161     (remove-hook 'post-command-hook 'egg-redraw-face)
 162     (while list
 163       (setq mb (car (car list))
 164             me (cdr (car list))
 165             list (cdr list))
 166       (when (marker-buffer mb)
 167         (set-buffer (marker-buffer mb))
 168         (let ((before-change-functions nil) (after-change-functions nil))
 169           (save-restriction
 170             (widen)
 171             (setq b (max mb (point-min))
 172                   e (min me (point-max)))
 173             (set-marker mb nil)
 174             (set-marker me nil)
 175             (while (< b e)
 176               (if (null (get-text-property b 'egg-face))
 177                   (setq b (next-single-property-change b 'egg-face nil e)))
 178               (setq p (next-single-property-change b 'egg-face nil e))
 179               (when (< b p)
 180                 (goto-char b)
 181                 (setq str (buffer-substring b p))
 182                 (delete-region b p)
 183                 (remove-text-properties 0 (- p b) '(face) str)
 184                 (insert str)
 185                 (setq b p)))))))
 186     (set-buffer org-buffer)
 187     (goto-char org-point)))
 188 \f
 189 (defun egg-hinshi-select ()
 190  (menudiag-select ; Should generate at initialization time
 191   '(menu  "\e$BIJ;lL>\e(B:"
 192           (("\e$BIaDLL>;l\e(B" .
 193             (menu  "\e$BIJ;lL>\e(B[\e$BIaDLL>;l\e(B]:"
 194                    ("\e$BL>;l\e(B" "\e$B%59T\e(B(\e$B$9$k\e(B)&\e$BL>;l\e(B" "\e$B0lCJ\e(B&\e$BL>;l\e(B"
 195                     "\e$B7AMFF0;l\e(B&\e$BL>;l\e(B" "\e$B?t;l\e(B")))
 196            ("\e$B8GM-L>;l\e(B" .
 197             (menu  "\e$BIJ;lL>\e(B[\e$B8GM-L>;l\e(B]:"
 198                    ("\e$B?ML>\e(B" "\e$BCOL>\e(B" "\e$B?ML>\e(B&\e$BCOL>\e(B" "\e$B8GM-L>;l\e(B")))
 199            ("\e$BF0;l\e(B" .
 200             (menu  "\e$BIJ;lL>\e(B[\e$BF0;l\e(B]:"
 201                    ("\e$B0lCJ\e(B" "\e$B0lCJ\e(B&\e$BL>;l\e(B" "\e$B%+9T8^CJ\e(B" "\e$B%,9T8^CJ\e(B"
 202                     "\e$B%59T8^CJ\e(B" "\e$B%?9T8^CJ\e(B")))
 203            ("\e$BFC<l$JF0;l\e(B" .
 204             (menu  "\e$BIJ;lL>\e(B[\e$BFC<l$JF0;l\e(B]:"
 205                    ("\e$B%+9T\e(B(\e$B9T$/\e(B)" "\e$B%i9T\e(B(\e$B2<$5$$\e(B)" "\e$BMh\e(B(\e$B$3\e(B)"
 206                     "\e$BMh\e(B(\e$B$-\e(B)" "\e$BMh\e(B(\e$B$/\e(B)" "\e$B0Y\e(B(\e$B$7\e(B)")))
 207            ("\e$BF0;l0J30$NMQ8@\e(B" .
 208             (menu  "\e$BIJ;lL>\e(B[\e$BF0;l0J30$NMQ8@\e(B]:"
 209                    ("\e$B7AMF;l\e(B" "\e$B7AMFF0;l\e(B" "\e$B7AMFF0;l\e(B&\e$BL>;l\e(B"
 210                     "\e$B7AMFF0;l\e(B(\e$B$?$k\e(B)")))))))
 211
 212 ;; XXX: Should use backend interface
 213 (defun egg-toroku-region (start end)
 214   (interactive "r")
 215   (let* ((env (wnn-get-environment wnn-dictionary-specification)) ; XXX
 216          (kanji (buffer-substring start end))
 217          (yomi (read-multilingual-string
 218                 (format "\e$B<-=qEPO?!X\e(B%s\e$B!Y\e(B  \e$BFI$_\e(B:" kanji)))
 219          (dic (menudiag-select (list 'menu "\e$BEPO?<-=qL>\e(B:"
 220                                  ;; XXX
 221                                  (wnn-list-writable-dictionaries-byname env))))
 222          (dic-name (wnn-dict-name dic))
 223          (hinshi (egg-hinshi-select))
 224          (hinshi-id (wnn-hinshi-number env hinshi)))
 225     (if (y-or-n-p
 226          (format "\e$B<-=q9`L\!X\e(B%s\e$B!Y\e(B(%s: %s)\e$B$r\e(B %s \e$B$KEPO?$7$^$9\e(B"
 227                  kanji yomi hinshi dic-name))
 228         (let ((r (wnn-add-word env dic yomi kanji "" hinshi-id 0)))
 229           (if (< r 0)
 230             (error "\e$B<-=qEPO?!X\e(B%s\e$B!Y\e(B(%s: %s) %s \e$B$K<:GT$7$^$7$?\e(B: %s"
 231                    kanji yomi hinshi dic-name
 232                    (wnnrpc-get-error-message (- r)))
 233             (message
 234              "\e$B<-=q9`L\!X\e(B%s\e$B!Y\e(B(%s: %s)\e$B$r\e(B %s \e$B$KEPO?$7$^$7$?\e(B"
 235              kanji yomi hinshi dic-name))))))
 236 \f
 237 ;;;
 238 ;;; auto fill controll
 239 ;;;
 240
 241 (defun egg-do-auto-fill ()
 242   (if (and auto-fill-function (> (current-column) fill-column))
 243       (let ((ocolumn (current-column)))
 244         (funcall auto-fill-function)
 245         (while (and (< fill-column (current-column))
 246                     (< (current-column) ocolumn))
 247           (setq ocolumn (current-column))
 248           (funcall auto-fill-function)))))
 249
 250 (require 'its)
 251 (require 'menudiag)
 252 (require 'egg-mlh)
 253 (require 'egg-cnv)
 254 (require 'egg-com)
 255 (require 'custom)                       ; Really?
 256
 257 (defgroup egg nil
 258   "Tamagotchy --- EGG Versio 4.0")
 259
 260 (add-hook 'kill-emacs-hook 'egg-kill-emacs-function)
 261 (defun egg-kill-emacs-function ()
 262   (egg-finalize-backend))
 263
 264 (provide 'egg)
 265
 266 ;;; egg.el ends here