(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$" ())
     ("$" ())
     )))