fixedpoint.jp - pluralize and singularize (2007-11-23)

2007/10/18 で Ruby on Rails が名詞の単複数形を使い分けて名前の衝突の防止に役立てていると書きました。このアイディアはどのフレームワークでも応用できるので、今回はその実装を真似て複数形への変形および単数形への変形を行う関数を Gauche で定義してみました。

でモジュール Inflector のメソッド pluralize と singularize として提供されているものです。

pluralize-and-singularize.scm

(use srfi-1)
(use srfi-13)

(define *uncountable*
  '(equipment information rice money spices series fish sheep))

(define *irregular*
  '((person . people)
    (man . men)
    (child . children)
    (sex . sexes)
    (move . moves)))

(define (specify-clause name str variant)
  `(and-let* ((m (rxmatch ,(string->regexp str :case-fold #t) ,name))
              ,@(map (lambda (i) `(,(string->symbol (format #f "m~d" i)) (m ,i))) (filter integer? variant)))
     (string-append (rxmatch-before m)
                    ,@(map (lambda (v) (if (integer? v) (string->symbol (format #f "m~d" v)) v)) variant))))

(define-macro (plural-case name . args)
  `(or
    ,@(map (lambda (x) (specify-clause name (format #f "^~a$" x) (list (symbol->string x)))) *uncountable*)
    ,@(map (lambda (x) (specify-clause name (format #f "~a$" (car x)) (list (symbol->string (cdr x))))) *irregular*)
    ,@(map (lambda (x) (apply specify-clause name x)) args)))

(define (pluralize name)
  (let ((name (x->string name)))
    (plural-case
     name
     ("(quiz)$" (1 "zes"))
     ("^(ox)$" (1 "en"))
     ("([ml])ouse$" (1 "ice"))
     ("(matr|vert|ind)(?:ix|ex)$" (1 "ices"))
     ("(x|ch|ss|sh)$" (1 "es"))
     ("([^aeiouy]|qu)y$" (1 "ies"))
     ("(hive)$" (1 "s"))
     ("([^f])fe$" (1 "ves"))
     ("([lr])f$" (1 "ves"))
     ("sis$" ("ses"))
     ("([ti])um$" (1 "a"))
     ("(buffal|tomat)o$" (1 "oes"))
     ("(bu)s$" (1 "ses"))
     ("(alias|status)$" (1 "es"))
     ("(octop|vir)us$" (1 "i"))
     ("(ax|test)is$" (1 "es"))
     ("s$" ("s"))
     ("$" ("s"))
     )))

(define-macro (singular-case name . args)
  `(or
    ,@(map (lambda (x) (specify-clause name (format #f "^~a$" x) (list (symbol->string x)))) *uncountable*)
    ,@(map (lambda (x) (specify-clause name (format #f "~a$" (cdr x)) (list (symbol->string (car x))))) *irregular*)
    ,@(map (lambda (x) (apply specify-clause name x)) args)))

(define (singularize name)
  (let ((name (x->string name)))
    (singular-case
     name
     ("(quiz)zes$" (1))
     ("(matr)ices$" (1 "ix"))
     ("(vert|ind)ices$" (1 "ex"))
     ("^(ox)en" (1))
     ("(alias|status)es$" (1))
     ("(octop|vir)i$" (1 "us"))
     ("(cris|ax|test)es$" (1 "is"))
     ("(shoe)s$" (1))
     ("(bus)es$" (1))
     ("(o)es$" (1))
     ("([ml])ice$" (1 "ouse"))
     ("(x|ch|ss|sh)es$" (1))
     ("(m)ovies$" (1 "ovie"))
     ("(s)eries$" (1 "eries"))
     ("([^aeiouy]|qu)ies$" (1 "y"))
     ("([lr])ves$" (1 "f"))
     ("(tive)s$" (1))
     ("(hive)s$" (1))
     ("([^f])ves$" (1 "fe"))
     ("(^analy)ses$" (1 "sis"))
     ("((a)naly|(b)a|(d)iagno|(p)arenthe|(p)rogno|(s)ynop|(t)he)ses$" (1 2 "sis"))
     ("([ti])a$" (1 "um"))
     ("(n)ews$" (1 "ews"))
     ("s$" ())
     ("$" ())
     )))

Rails 同様、カバーしていない不規則変化を簡単に追加できるという特徴があります。