cgit.sxemacs.org Git - packages/blob - mule-packages/skk/skk-kcode.el

   1 ;;; skk-kcode.el --- \e$B4A;z%3!<%I$r;H$C$?JQ49$N$?$a$N%W%m%0%i%`\e(B
   2 ;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998,
   3 ;;               1999
   4 ;; Masahiko Sato <masahiko@kuis.kyoto-u.ac.jp>
   5
   6 ;; Author: Masahiko Sato <masahiko@kuis.kyoto-u.ac.jp>
   7 ;; Maintainer: Mikio Nakajima <minakaji@osaka.email.ne.jp>
   8 ;; Version: $Id: skk-kcode.el,v 1.2 2000-07-10 04:34:00 yoshiki Exp $
   9 ;; Keywords: japanese
  10 ;; Last Modified: $Date: 2000-07-10 04:34:00 $
  11
  12 ;; This file is part of SKK.
  13
  14 ;; SKK is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either versions 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; SKK is distributed in the hope that it will be useful
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with SKK, see the file COPYING.  If not, write to the Free
  26 ;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston,
  27 ;; MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32 (eval-when-compile (require 'skk))
  33 (require 'skk-foreword)
  34
  35 ;;;###autoload
  36 (defgroup skk-kcode nil "SKK Kanji Code related customization."
  37   :prefix "skk-"
  38   :group 'skk )
  39
  40 (defcustom skk-input-by-code-menu-keys1 '(?a ?s ?d ?f ?g ?h ?q ?w ?e ?r ?t ?y)
  41   "*\e$B%a%K%e!<7A<0$G\e(B JIS \e$BJ8;z$rF~NO$9$k$H$-$K;HMQ$9$kA*Br%-!<$N%j%9%H!#\e(B
  42 \e$BBh\e(B 1 \e$BCJ3,$N%a%K%e!<$G;HMQ$9$k!#\e(B
  43 12 \e$B8D$N%-!<\e(B (char type) \e$B$r4^$`I,MW$,$"$k!#\e(B"
  44   :type '(repeat character)
  45   :group 'skk-kcode )
  46
  47 (defcustom skk-input-by-code-menu-keys2
  48   '(?a ?s ?d ?f ?g ?h ?j ?k ?l ?q ?w ?e ?r ?t ?y ?u)
  49   "*\e$B%a%K%e!<7A<0$G\e(B JIS \e$BJ8;z$rF~NO$9$k$H$-$K;HMQ$9$kA*Br%-!<$N%j%9%H!#\e(B
  50 \e$BBh\e(B 2 \e$BCJ3,$N%a%K%e!<$G;HMQ$9$k!#\e(B
  51 16 \e$B8D$N%-!<\e(B (char type) \e$B$r4^$`I,MW$,$"$k!#\e(B"
  52   :type '(repeat character)
  53   :group 'skk-kcode )
  54
  55 (defcustom skk-kcode-charset
  56   (if (memq skk-emacs-type '(xemacs mule4 mule3))
  57       'japanese-jisx0208
  58     lc-jp )
  59   "*skk-input-by-code-or-menu \e$B$G;H$o$l$kJ8;z%;%C%H!#\e(B"
  60   :type 'symbol
  61   :group 'skk-kcode )
  62
  63 (defcustom skk-kcode-load-hook nil
  64   "*skk-kcode.el \e$B$r%m!<%I$7$?8e$K%3!<%k$5$l$k%U%C%/!#\e(B"
  65   :type 'hook
  66   :group 'skk-kcode )
  67
  68 ;; internal constants and variables.
  69 (defconst skk-code-n1-min 161)
  70 (defconst skk-code-n1-max 244)
  71 (defconst skk-code-n2-min 161)
  72 (defconst skk-code-n2-max 254)
  73 (defconst skk-code-null 128)
  74 (defconst skk-kcode-charset-list
  75   (if (memq skk-emacs-type '(xemacs mule4 mule3))
  76       (mapcar '(lambda (x) (list (symbol-name x))) (charset-list)) ))
  77 (defvar skk-input-by-code-or-menu-jump-default skk-code-n1-min)
  78
  79 ;;;###autoload
  80 (defun skk-input-by-code-or-menu (&optional arg)
  81   "7bit \e$B$b$7$/$O\e(B 8bit \e$B$b$7$/$O\e(B \e$B6hE@%3!<%I$KBP1~$9$k\e(B 2byte \e$BJ8;z$rA^F~$9$k!#\e(B"
  82   (interactive "*P")
  83   (if arg
  84       (let ((charset
  85              (intern (completing-read (format "CHARSET(%s): " skk-kcode-charset)
  86                                       skk-kcode-charset-list nil t ))))
  87         (cond ((eq charset (intern "")))
  88               ((not (skk-charsetp charset))
  89                (skk-error "\e$BL58z$J%-%c%i%/%?!<%;%C%H$G$9\e(B" "Invalid charset"))
  90               (t (setq skk-kcode-charset charset)) )))
  91   (let ((str
  92          (read-string
  93           (format
  94            "7/8 bits or KUTEN code for %s (00nn or CR for Jump Menu): "
  95            skk-kcode-charset )))
  96         (enable-recursive-minibuffer t)
  97         n1 n2 )
  98     (if (string-match "\\(.+\\)-\\(.+\\)" str)
  99         (setq n1 (+ (string-to-number (match-string 1 str)) 32 128)
 100               n2 (+ (string-to-number (match-string 2 str)) 32 128) )
 101       (setq n1 (if (string= str "") 128
 102                  (+ (* 16 (skk-char-to-hex (aref str 0) 'jis))
 103                     (skk-char-to-hex (aref str 1)) ))
 104             n2 (if (string= str "") 128
 105                  (+ (* 16 (skk-char-to-hex (aref str 2) 'jis))
 106                     (skk-char-to-hex (aref str 3)) ))))
 107     (if (or (> n1 256) (> n2 256))
 108         (skk-error "\e$BL58z$J%3!<%I$G$9\e(B" "Invalid code") )
 109     (insert (if (> n1 160)
 110                 (skk-make-string n1 n2)
 111               (skk-input-by-code-or-menu-0 n1 n2) ))
 112     (if skk-henkan-active (skk-kakutei)) ))
 113
 114 (defun skk-char-to-hex (char &optional jischar)
 115   (cond ((and (<= char 102) (> char 96)) (- char 87)) ; a-f
 116         ((and (<= char 70) (> char 64)) (- char 55)) ; A-F
 117         ((and (<= char 57) (> char 47)) ; 0-9
 118          (cond (jischar (- char 40)) (t (- char 48)) ))
 119         (t (skk-error "%c \e$B$r\e(B 16 \e$B?J?t$KJQ49$G$-$^$;$s\e(B"
 120                       "Cannot convert %c to hexadecimal number" char))))
 121
 122 (defun skk-make-string (n1 n2)
 123   (char-to-string (skk-make-char skk-kcode-charset n1 n2)) )
 124
 125 (defun skk-next-n2-code (n)
 126   (if (<= (setq n (1+ n)) skk-code-n2-max) n skk-code-n2-min))
 127
 128 (defun skk-previous-n2-code (n)
 129   (if (<= skk-code-n2-min (setq n (1- n))) n skk-code-n2-max))
 130
 131 (defun skk-next-n1-code (n)
 132   (if (<= (setq n (1+ n)) skk-code-n1-max) n skk-code-n1-min))
 133
 134 (defun skk-previous-n1-code (n)
 135   (if (<= skk-code-n1-min (setq n (1- n))) n skk-code-n1-max))
 136
 137 (defun skk-input-by-code-or-menu-0 (n1 n2)
 138   (if (= n1 skk-code-null)
 139       (skk-input-by-code-or-menu-jump n2)
 140     (skk-input-by-code-or-menu-1 n1 n2)))
 141
 142 (defun skk-input-by-code-or-menu-jump (n)
 143   (let ((menu-keys1 ; \e$BI=<(MQ$N%-!<%j%9%H$rAH$_N)$F$k!#\e(B
 144          (mapcar (function (lambda (char) (char-to-string (upcase char))))
 145                  skk-input-by-code-menu-keys1 ))
 146         kanji-char )
 147     (if (< n skk-code-n1-min) (setq n skk-input-by-code-or-menu-jump-default))
 148     (while (not kanji-char)
 149       (let ((n-org n)
 150             (chars
 151              (list
 152               (list (skk-make-string n skk-code-n1-min) n skk-code-n1-min)
 153               (list (skk-make-string n 177) n 177)
 154               (list (skk-make-string n 193) n 193)
 155               (list (skk-make-string n 209) n 209)
 156               (list (skk-make-string n 225) n 225)
 157               (list (skk-make-string n 241) n 241)
 158               (progn
 159                 (setq n (skk-next-n1-code n))
 160                 (list (skk-make-string n skk-code-n1-min) n
 161                       skk-code-n1-min ))
 162               (list (skk-make-string n 177) n 177)
 163               (list (skk-make-string n 193) n 193)
 164               (list (skk-make-string n 209) n 209)
 165               (list (skk-make-string n 225) n 225)
 166               (list (skk-make-string n 241) n 241))))
 167         (skk-save-point
 168           (let ((i 0) message-log-max str )
 169             (while (< i 12)
 170               (setq str (concat str (nth i menu-keys1) ":" (car (nth i chars))
 171                                 "  " ))
 172               (setq i (1+ i)) )
 173             (message str) )
 174           (let ((char (event-to-character (skk-read-event)))
 175                 rest ch )
 176             (if (not (characterp char))
 177                 (progn
 178                   (skk-message "\"%s\" \e$B$OM-8z$J%-!<$G$O$"$j$^$;$s!*\e(B"
 179                                "\"%s\" is not valid here!" (prin1 char) )
 180                   (sit-for 1)
 181                   (message "")
 182                   (setq n n-org) )
 183               (setq rest (or (memq char skk-input-by-code-menu-keys1)
 184                              (if (skk-lower-case-p char)
 185                                  (memq (upcase char) skk-input-by-code-menu-keys1)
 186                                (memq (downcase char) skk-input-by-code-menu-keys1) ))
 187                     ch (if rest
 188                            ;; 12 == (length skk-input-by-code-menu-keys1)
 189                            (nth (- 12 (length rest)) chars)
 190                          nil )
 191                     kanji-char
 192                     (cond
 193                      (ch)
 194                      ((eq char ?x)
 195                       (if (< (setq n (- n-org 2)) skk-code-n1-min)
 196                           (setq n skk-code-n1-max))
 197                       nil)
 198                      ((eq char ?\040)
 199                       (setq n (skk-next-n1-code n))
 200                       nil)
 201                      ((eq char ?\?)
 202                       (skk-message
 203                        (concat "\e$B!X\e(B%s\e$B!Y\e(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
 204                                "[\e$B2?$+%-!<$r2!$7$F$/$@$5$$\e(B]" )
 205                        (concat "\e$B!X\e(B%s\e$B!Y\e(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
 206                                "[Hit any key to continue]" )
 207                        (car (car chars))
 208                        n-org skk-code-n1-min n-org skk-code-n1-min
 209                        (- n-org 128) (- skk-code-n1-min 128)
 210                        (- n-org 128) (- skk-code-n1-min 128) )
 211                       (skk-read-event)
 212                       (setq n n-org)
 213                       nil)
 214                      (t
 215                       (skk-message "\"%c\" \e$B$OM-8z$J%-!<$G$O$"$j$^$;$s!*\e(B"
 216                                    "\"%c\" is not valid here!" char )
 217                       (sit-for 1)
 218                       (message "")
 219                       (setq n n-org)
 220                       nil ))))))))
 221     (setq skk-input-by-code-or-menu-jump-default (car (cdr kanji-char)))
 222     (skk-input-by-code-or-menu-1
 223      (car (cdr kanji-char)) (car (cdr (cdr kanji-char))) )))
 224
 225 (defun skk-input-by-code-or-menu-1 (n1 n2)
 226   (let ((menu-keys2 ; \e$BI=<(MQ$N%-!<%j%9%H$rAH$_N)$F$k!#\e(B
 227          (mapcar (function (lambda (char) (char-to-string (upcase char))))
 228                  skk-input-by-code-menu-keys2 ))
 229         kanji-char )
 230     (while (not kanji-char)
 231       (let ((n1-org n1) (n2-org n2) (i 0)
 232             (chars (list (skk-make-string n1 n2))))
 233         ;; 16 == (length skk-input-by-code-menu-keys2)
 234         (while (< i 16)
 235           (nconc chars (list
 236                         (progn (setq n2 (skk-next-n2-code n2))
 237                                (if (= n2 skk-code-n2-min)
 238                                    (setq n1 (skk-next-n1-code n1)))
 239                                (skk-make-string n1 n2))))
 240           (setq i (1+ i)))
 241         (skk-save-point
 242           (let ((i 0) message-log-max str )
 243             (while (< i 16)
 244               (setq str (concat str (nth i menu-keys2) ":" (nth i chars) " "))
 245               (setq i (1+ i)) )
 246             (message str) )
 247           (let ((char (event-to-character (skk-read-event)))
 248                 rest ch )
 249             (if (not (characterp char))
 250                 (progn
 251                   (skk-message "\"%s\" \e$B$OM-8z$J%-!<$G$O$"$j$^$;$s!*\e(B"
 252                                "\"%s\" is not valid here!" (prin1 char) )
 253                   (sit-for 1)
 254                   (message "")
 255                   (setq n1 n1-org n2 n2-org) )
 256               (setq rest
 257                     (or (memq char skk-input-by-code-menu-keys2)
 258                         (if (skk-lower-case-p char)
 259                             (memq (upcase char) skk-input-by-code-menu-keys2)
 260                           (memq (downcase char) skk-input-by-code-menu-keys2) ))
 261                     ch (if rest
 262                            ;; 16 == (length skk-input-by-code-menu-keys2)
 263                            (nth (- 16 (length rest)) chars) )
 264                     kanji-char
 265                     (cond
 266                      (ch)
 267                      ((eq char ?x)
 268                       (if (< (setq n2 (- n2 31)) skk-code-n2-min)
 269                           (setq n2 (+ n2 94)
 270                                 n1 (skk-previous-n1-code n1)))
 271                       nil )
 272                      ((eq char ?\040) ; space
 273                       (if (= (setq n2 (skk-next-n2-code n2))
 274                              skk-code-n2-min)
 275                           (setq n1 (skk-next-n1-code n1)))
 276                       nil )
 277                      ((eq char ?\?)
 278                       (skk-message
 279                        (concat "\e$B!X\e(B%s\e$B!Y\e(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
 280                                "[\e$B2?$+%-!<$r2!$7$F$/$@$5$$\e(B]" )
 281                        (concat "\e$B!X\e(B%s\e$B!Y\e(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
 282                                "[Hit any key to continue]" )
 283                        (car chars) n1-org n2-org n1-org n2-org
 284                        (- n1-org 128) (- n2-org 128)
 285                        (- n1-org 128) (- n2-org 128) )
 286                       (skk-read-event)
 287                       (setq n1 n1-org n2 n2-org)
 288                       nil )
 289                      ((eq char ?>)
 290                       (if (= (setq n2 (skk-next-n2-code n2-org))
 291                              skk-code-n2-min)
 292                           (setq n1 (skk-next-n1-code n1-org))
 293                         (setq n1 n1-org))
 294                       nil )
 295                      ((eq char ?<)
 296                       (if (= (setq n2 (skk-previous-n2-code n2-org))
 297                              skk-code-n2-max)
 298                           (setq n1 (skk-previous-n1-code n1-org))
 299                         (setq n1 n1-org))
 300                       nil )
 301                      (t
 302                       (skk-message "\"%c\" \e$B$OM-8z$J%-!<$G$O$"$j$^$;$s!*\e(B"
 303                                    "\"%c\" is not valid here!" char )
 304                       (sit-for 1)
 305                       (message "")
 306                       (setq n1 n1-org n2 n2-org)
 307                       nil ))))))))
 308     kanji-char ))
 309
 310 ;;;###autoload
 311 (defun skk-display-code-for-char-at-point (&optional arg)
 312   "\e$B%]%$%s%H$K$"$kJ8;z$N\e(B EUC \e$B%3!<%I$H\e(B JIS \e$B%3!<%I$rI=<($9$k!#\e(B"
 313   (interactive "P")
 314   (if (eobp)
 315       (skk-error "\e$B%+!<%=%k$,%P%C%U%!$N=*C<$K$"$j$^$9\e(B"
 316                  "Cursor is at the end of the buffer" )
 317     (skk-display-code (buffer-substring-no-properties
 318                        (point) (skk-save-point (forward-char 1) (point)) ))
 319     ;; \e$B%(%3!<$7$?J8;zNs$r%+%l%s%H%P%C%U%!$KA^F~$7$J$$$h$&$K!#\e(B
 320     t ))
 321
 322 (defun skk-display-code (str)
 323   (static-cond
 324    ((memq skk-emacs-type '(xemacs mule4 mule3))
 325     (let* ((char (string-to-char str))
 326            (charset (char-charset char)))
 327       (cond
 328        ((memq charset '(japanese-jisx0208 japanese-jisx0208-1978))
 329         (let* ((char1-j (skk-char-octet char 0))
 330                (char1-k (- char1-j 32))
 331                (char1-e (+ char1-j 128))
 332                (char2-j (skk-char-octet char 1))
 333                (char2-k (- char2-j 32))
 334                (char2-e (+ char2-j 128)))
 335           (message
 336            "\e$B!X\e(B%s\e$B!Y\e(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d), KUTEN: (%2d, %2d)"
 337            str char1-e char2-e char1-e char2-e
 338            char1-j char2-j char1-j char2-j char1-k char2-k)))
 339        ((memq charset '(ascii latin-jisx0201))
 340         (message "\"%s\"  %2x (%3d)"
 341                  str (skk-char-octet char 0)  (skk-char-octet char 0)))
 342        (t
 343         (skk-error "\e$BH=JL$G$-$J$$J8;z$G$9\e(B"
 344                    "Cannot understand this character" )))))
 345    ;; 'mule2
 346    (t
 347     (let (;; \e$BJ8;zNs$r\e(B char \e$B$KJ,2r!#\e(B
 348           ;; (mapcar '+ str) == (append str nil)
 349           (char-list (mapcar (function +) str)))
 350       (cond
 351        ((and (= (length char-list) 3)
 352              (memq (car char-list) (list lc-jp lc-jpold)))
 353         (let* ((char1-e (car (cdr char-list)))
 354                (char1-j (- char1-e 128))
 355                (char1-k (- char1-j 32))
 356                (char2-e (car (cdr (cdr char-list))))
 357                (char2-j (- char2-e 128))
 358                (char2-k (- char2-j 32)))
 359           (message
 360            "\e$B!X\e(B%s\e$B!Y\e(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d), KUTEN: (%2d, %2d)"
 361            str char1-e char2-e char1-e char2-e
 362            char1-j char2-j char1-j char2-j char1-k char2-k)))
 363        ((or (= (length char-list) 1)    ; ascii character
 364             (memq (car char-list) (list lc-ascii lc-roman)))
 365         (let ((char (car char-list)))
 366           (message "\"%c\"  %2x (%3d)" char char char) ))
 367        (t
 368         (skk-error "\e$BH=JL$G$-$J$$J8;z$G$9\e(B"
 369                    "Cannot understand this character" )))))))
 370
 371 (run-hooks 'skk-kcode-load-hook)
 372
 373 (provide 'skk-kcode)
 374 ;;; skk-kcode.el ends here