文字列の正規化

昨日はMeCabバインディングを取り上げたが、MeCabを使うようなコードを書いている場合、文字列を正規化したくなることがたまにある。

なので、簡単な文字列正規化関数をlispで実装してみることにする。
※ ただし、文字の内部的なコード(char-code)に依存しているので、このコードはおそらくsbclに依存している(ポータブルではない)と思う。

;; #\a + 1 -> #\b
(defun char+ (chr n)
  (code-char (+ n (char-code chr))))

;; fromから始まる文字群を、toから始まる文字群へマップ
;; normalize-charマクロで使われる補助関数
(defun expand-convert-pairs (from to length &optional (step 1))
  (loop for i from 0 to (1- length) collect
    `(,(if (atom from) 
	   (char+ from i)
	 (mapcar (lambda (c) (char+ c i)) from))
      ,(code-char (+ (* i step) (char-code to))))))

;; 文字の正規化テーブル(case)作成マクロ
(defmacro normalize-char (str i len)
 `(let ((chr (char ,str ,i)))
    (case chr
      ,@(expand-convert-pairs '(#\Ａ #\A #\ａ) #\a 26) ;英字
      ,@(expand-convert-pairs #\０ #\0 10)             ;数字
      ,@(expand-convert-pairs #\ｱ #\ア 5 2)            ;カタカナ-ア行
      ,@(expand-convert-pairs #\ｧ #\ァ 5 2)            ;カタカナ-小さいア行
                                                       ;カタカナ-タチ
      ((#\ﾀ #\ﾁ) (if (or #1=(>= ,i (1- ,len)) (char/= #2=(char ,str (1+ ,i)) #\ﾞ)) 
		     (case chr ,@(expand-convert-pairs #\ﾀ #\タ 2 2))
		   (prog1 (case chr ,@(expand-convert-pairs #\ﾀ #\ダ 2 2))
		     (setf delete? t  ,i (1+ ,i)))))
      (#\ﾂ (if (or #1# (char/= #2# #\ﾞ))                ;カタカナ-ツ
	       #\ツ
	     (progn (setf delete? t ,i (1+ ,i))
		    #\ヅ))) 
      (#\ｯ #\ッ)                                        ;カタカタ-ッ
      ((#\ﾃ #\ﾄ) (if (or #1# (char/= #2# #\ﾞ))          ;カタカナ-テト
		     (case chr ,@(expand-convert-pairs #\ﾃ #\テ 2 2))
		   (prog1 (case chr ,@(expand-convert-pairs #\ﾃ #\デ 2 2))
		     (setf delete? t  ,i (1+ ,i)))))
      ,@(expand-convert-pairs #\ﾅ #\ナ 5)               ;カタカナ-ナ行
      ,@(expand-convert-pairs #\ﾏ #\マ 5)               ;カタカナ-マ行
      ,@(expand-convert-pairs #\ﾔ #\ヤ 3 2)             ;カタカナ-ヤ行
      ,@(expand-convert-pairs #\ｬ #\ャ 3 2)             ;カタカナ-小さいヤ行
      ,@(expand-convert-pairs #\ﾗ #\ラ 5)               ;カタカナ-ラ行
      (#\ﾜ #\ワ)                                        ;カタカナ-ワ
      (#\ｦ #\ヲ)                                        ;カタカナ-ヲ
      (#\ﾝ #\ン)                                        ;カタカナ-ン
      ((#\ｶ #\ｷ #\ｸ #\ｹ #\ｺ #\ｻ #\ｼ #\ｽ #\ｾ #\ｿ)         ;濁点つきカタカナ
       (if (or #1# (char/= #2# #\ﾞ))
	   (case chr ,@(expand-convert-pairs #\ｶ #\カ 10 2))
	 (prog1 (case chr ,@(expand-convert-pairs #\ｶ #\ガ 10 2))
	   (setf delete? t  ,i (1+ ,i)))))
      ((#\ﾊ #\ﾋ #\ﾌ #\ﾍ #\ﾎ)                             ;濁点・半濁点つきカタカナ
       (cond (#1# #3=(case (char ,str ,i) ,@(expand-convert-pairs #\ﾊ #\ハ 5 3)))
	     ((char= #2# #\ﾟ) (prog1 (case chr ,@(expand-convert-pairs #\ﾊ #\パ 5 3))
				(setf delete? t  #2# #\ﾞ  ,i (1+ ,i))))
	     ((char= #2# #\ﾞ) (prog1 (case chr ,@(expand-convert-pairs #\ﾊ #\バ 5 3))
				(setf delete? t  ,i (1+ ,i))))
	     (t #3#)))
      (#\　 #\ )                                         ;空白文字
      ,@(expand-convert-pairs #\！ #\! 15)               ;記号1
      ,@(expand-convert-pairs #\： #\: 7)                ;記号2
      ,@(expand-convert-pairs #\［ #\[ 6)                ;記号3
      ,@(expand-convert-pairs #\｛ #\{ 4)                ;記号4
      ,@(expand-convert-pairs #\「 #\｢ 2)                ;記号5
      (#\。 #\｡)                                         ;以下、その他　　　　　　　　　　　　　　　　　　　　　
      (#\、 #\､)
      (#\・ #\･)
      ((#\ｰ #\ー) #\−)                                  
      (t chr))))                                         ;変換不要な文字

;;;;
;; 文字列正規化
(defun normalize-string (str)
  (let ((len (length str)) (delete? nil))
    (dotimes (i len)
      (setf (char str i) (normalize-char str i len)))
    (if delete? 
	(delete #\ﾞ str :test #'char=)
      str)))

実行結果

>(normalize-string "１２34−aBＣｄ、＠アｱガｶﾞ")ただ、濁点・半濁点が含まれる文字列を正規化した場合、文字列の長さが変わることがあるので注意が必要だ。
--> "1234−abcd､@アアガガ"

できてるっぽい。※ 濁点がつく半角カタカナを全角に変換しているので、正規化の前後で文字列の長さは異なる


文字と文字とのマッピングは、自分が思いつくままに設定したので不適切なものや、対応もれなどもあるだろうが、とりあえず簡単に使う分には、これで充分だろう。