読者です 読者をやめる 読者になる 読者になる

文字列の正規化

sbcl common lisp

昨日は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 #\a) #\a 26) ;英字
      ,@(expand-convert-pairs #\0 #\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 "1234−aBCd、@アアガガ")ただ、濁点・半濁点が含まれる文字列を正規化した場合、文字列の長さが変わることがあるので注意が必要だ。
--> "1234−abcd、@アアガガ"

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


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