;;; kana-keyboard.el --- Japanese Kana Keyboard support

;; Copyright (C) 1999 by Free Software Foundation, Inc.

;; Author: SL Baur <steve@xemacs.org>
;; Keywords: mule, hardware

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; This file contains keybindings to make a Kana keyboard useful.  It requires
;; X11 keysym support on the X server and (of course) a keyboard that can
;; directly generate kana symbols.

;;; Code:

(eval-when-compile
  (require 'cl))

(defconst kana-keyboard-data
  '(
    (kana_A ?あ ?ア)
    (kana_a ?ぁ ?ァ)
    (kana_I ?い ?イ)
    (kana_i ?ぃ ?ィ)
    (kana_U ?う ?ウ)
    (kana_u ?ぅ ?ゥ)
    (kana_E ?え ?エ)
    (kana_e ?ぇ ?ェ)
    (kana_O ?お ?オ)
    (kana_o ?ぉ ?ォ)

    (kana_KA ?か ?カ)
    (kana_KI ?き ?キ)
    (kana_KU ?く ?ク)
    (kana_KE ?け ?ケ)
    (kana_KO ?こ ?コ)

    (kana_SA ?さ ?サ)
    (kana_SHI ?し ?シ)
    (kana_SU ?す ?ス)
    (kana_SE ?せ ?セ)
    (kana_SO ?そ ?ソ)

    (kana_TA ?た ?タ)
    (kana_CHI ?ち ?チ)
    (kana_TSU ?つ ?ツ)
    (kana_tsu ?っ ?ッ)
    (kana_TE ?て ?テ)
    (kana_TO ?と ?ト)

    (kana_MA ?ま ?マ)
    (kana_MI ?み ?ミ)
    (kana_MU ?む ?ム)
    (kana_ME ?め ?メ)
    (kana_MO ?も ?モ)

    (kana_HA ?は ?ハ)
    (kana_HI ?ひ ?ヒ)
    (kana_FU ?ふ ?フ)
    (kana_HE ?へ ?ヘ)
    (kana_HO ?ほ ?ホ)

    (kana_NA ?な ?ナ)
    (kana_NI ?に ?ニ)
    (kana_NU ?ぬ ?ヌ)
    (kana_NE ?ね ?ネ)
    (kana_NO ?の ?ノ)

    (kana_YA ?や ?ヤ)
    (kana_ya ?ゃ ?ャ)
    (kana_YU ?ゆ ?ユ)
    (kana_yu ?ゅ ?ュ)
    (kana_YO ?よ ?ヨ)
    (kana_yo ?ょ ?ョ)

    (kana_RA ?ら ?ラ)
    (kana_RI ?り ?リ)
    (kana_RU ?る ?ル)
    (kana_RE ?れ ?レ)
    (kana_RO ?ろ ?ロ)

    (kana_WA ?わ ?ワ)
    (kana_WO ?を ?ヲ)

    (kana_N ?ん ?ン)

    (prolongedsound ?ー ?ー)
    ;; (voicedsound ? ?)
    ;; (semivoicedsound ? ?)
    (kana_openingbracket ?\「 ?\「)
    (kana_closingbracket ?\」 ?\」)
    (kana_fullstop ?。 ?。)
    (kana_comma ?、 ?、)
    (kana_conjunctive ?・ ?・)))

;;; Postfixed voiced sound support from MORIOKA Tomohiko
(defun kana-keyboard-postfix-voicedsound (arg)
  (interactive "P")
  (let ((ret (assq (char-before)
		   '((?か . ?が)
		     (?き . ?ぎ)
		     (?く . ?ぐ)
		     (?け . ?げ)
		     (?こ . ?ご)
		     (?さ . ?ざ)
		     (?し . ?じ)
		     (?す . ?ず)
		     (?せ . ?ぜ)
		     (?そ . ?ぞ)
		     (?た . ?だ)
		     (?ち . ?ぢ)
		     (?つ . ?づ)
		     (?て . ?で)
		     (?と . ?ど)
		     (?は . ?ば)
		     (?ひ . ?び)
		     (?ふ . ?ぶ)
		     (?へ . ?べ)
		     (?ほ . ?ぼ)
		     (?ウ . ?ヴ)
		     (?カ . ?ガ)
		     (?キ . ?ギ)
		     (?ク . ?グ)
		     (?ケ . ?ゲ)
		     (?コ . ?ゴ)
		     (?サ . ?ザ)
		     (?シ . ?ジ)
		     (?ス . ?ズ)
		     (?セ . ?ゼ)
		     (?ソ . ?ゾ)
		     (?タ . ?ダ)
		     (?チ . ?ヂ)
		     (?ツ . ?ヅ)
		     (?テ . ?デ)
		     (?ト . ?ド)
		     (?ハ . ?バ)
		     (?ヒ . ?ビ)
		     (?フ . ?ブ)
		     (?ヘ . ?ベ)
		     (?ホ . ?ボ)
		     ))))
    (self-insert-internal
     (if ret
	 (progn
	   (delete-backward-char 1 nil)
	   (cdr ret))
       ?゛))))

(defun kana-keyboard-postfix-semivoicedsound (arg)
  (interactive "P")
  (let ((ret (assq (char-before)
		   '((?は . ?ぱ)
		     (?ひ . ?ぴ)
		     (?ふ . ?ぷ)
		     (?へ . ?ぺ)
		     (?ほ . ?ぽ)
		     (?ハ . ?パ)
		     (?ヒ . ?ピ)
		     (?フ . ?プ)
		     (?ヘ . ?ぺ)
		     (?ホ . ?ポ)
		     ))))
    (self-insert-internal
     (if ret
	 (progn
	   (delete-backward-char 1 nil)
	   (cdr ret))
       ?゛))))


(defvar kana-keyboard-hiragana-flag t
  "Non nil if kana keys generate hiragana by default.")

(defun kana-keyboard-hiragana (arg)
  "Make kana keys generate hiragana."
  (interactive "P")
  (setq kana-keyboard-hiragana-flag t))

(defun kana-keyboard-katakana (arg)
  "Make kana keys generate katakana."
  (interactive "P")
  (setq kana-keyboard-hiragana-flag nil))

(defmacro kana-keyboard-self-insert (hira kata)
  `(lambda (arg)
     (interactive "P")
     (if kana-keyboard-hiragana-flag
	 (self-insert-internal ,hira)
       (self-insert-internal ,kata))))

;; The following doesn't work bytecompiled
;(defmacro kana-keyboard-self-insert (hira kata)
;  `(lambda (arg)
;     (interactive "P")
;     (if kana-keyboard-hiragana-flag
;	 (self-insert-internal ,(eval hira))
;       (self-insert-internal ,(eval kata)))))

;(defun kana-keyboard-define-keys ()
;  (define-key global-map [(voicedsound)] 'kana-keyboard-postfix-voicedsound)
;  (define-key global-map
;    [(semivoicedsound)]
;    'kana-keyboard-postfix-semivoicedsound)
;  (define-key global-map [(hiragana)] 'kana-keyboard-hiragana)
;  (define-key global-map [(katakana)] 'kana-keyboard-katakana)
;  (let (keydef
;	(keys kana-keyboard-data))
;    (while (setq keydef (pop keys))
;      (define-key global-map
;	(vector (list (car keydef)))
;	(kana-keyboard-self-insert (cadr keydef) (caddr keydef))))))

;;;###autoload
(defun kana-keyboard-define-keys ()
  (define-key global-map [(voicedsound)] 'kana-keyboard-postfix-voicedsound)
  (define-key global-map
    [(semivoicedsound)]
    'kana-keyboard-postfix-semivoicedsound)
  (define-key global-map [(hiragana)] 'kana-keyboard-hiragana)
  (define-key global-map [(katakana)] 'kana-keyboard-katakana)
  (let (keydef
	(keys kana-keyboard-data))
    (while (setq keydef (pop keys))
      (define-key global-map
	(vector (list (car keydef)))
	`(lambda (arg)
	   (interactive "P")
	   (if kana-keyboard-hiragana-flag
	       (self-insert-internal ,(cadr keydef))
	     (self-insert-internal ,(caddr keydef))))))))

(provide 'kana-keyboard)

;;; kana-keyboard.el ends here