dajare.rkt

#lang racket
(require srfi/1)
(require srfi/9)
(require srfi/13)

(define (vowel? chr)
  (let ((chr-int (char->integer chr)))
    (and (<= 12354 chr-int 12362)
         (even? chr-int))))

(define kana-je
  '(("あ" . (#f a #f))
    ("い" . (#f i #f))
    ("う" . (#f u #f))
    ("え" . (#f e #f))
    ("お" . (#f o #f))
    ("か" . (k a #f))
    ("き" . (k i #f))
    ("く" . (k u #f))
    ("け" . (k e #f))
    ("こ" . (k o #f))
    ("さ" . (s a #f))
    ("し" . (s i #f))
    ("す" . (s u #f))
    ("せ" . (s e #f))
    ("そ" . (s o #f))
    ("た" . (t a #f))
    ("ち" . (t i #f))
    ("つ" . (t u #f))
    ("て" . (t e #f))
    ("と" . (t o #f))
    ("な" . (n a #f))
    ("に" . (n i #f))
    ("ぬ" . (n u #f))
    ("ね" . (n e #f))
    ("の" . (n o #f))
    ("は" . (h a #f))
    ("ひ" . (h i #f))
    ("ふ" . (h u #f))
    ("へ" . (h e #f))
    ("ほ" . (h o #f))
    ("ま" . (m a #f))
    ("み" . (m i #f))
    ("む" . (m u #f))
    ("め" . (m e #f))
    ("も" . (m o #f))
    ("や" . (y a #f))
    ("ゆ" . (y u #f))
    ("よ" . (y o #f))
    ("ら" . (r a #f))
    ("り" . (r i #f))
    ("る" . (r u #f))
    ("れ" . (r e #f))
    ("ろ" . (r o #f))
    ("わ" . (w a #f))
    ("を" . (w o #f))
    ("ん" . (n #f #f))
    ("が" . (g a #f))
    ("ぎ" . (g i #f))
    ("ぐ" . (g u #f))
    ("げ" . (g e #f))
    ("ご" . (g o #f))
    ("ざ" . (z a #f))
    ("じ" . (z i #f))
    ("ず" . (z u #f))
    ("ぜ" . (z e #f))
    ("ぞ" . (z o #f))
    ("だ" . (d a #f))
    ("ぢ" . (d i #f))
    ("づ" . (d u #f))
    ("で" . (d e #f))
    ("ど" . (d o #f))
    ("ば" . (b a #f))
    ("び" . (b i #f))
    ("ぶ" . (b u #f))
    ("べ" . (b e #f))
    ("ぼ" . (b p #f))
    ("ぱ" . (p a #f))
    ("ぴ" . (p i #f))
    ("ぷ" . (p u #f))
    ("ぺ" . (p e #f))
    ("ぽ" . (p o #f))
    ("きゃ" . (k a #t))
    ("きゅ" . (k u #t))
    ("きょ" . (k o #t))
    ("しゃ" . (s a #t))
    ("しゅ" . (s u #t))
    ("しぇ" . (s e #t))
    ("しょ" . (s o #t))
    ("ちゃ" . (t a #t))
    ("ちゅ" . (t u #t))
    ("ちぇ" . (t e #t))
    ("ちょ" . (t o #t))
    ("にゃ" . (n a #t))
    ("にゅ" . (n u #t))
    ("にょ" . (n o #t))
    ("ひゃ" . (h a #t))
    ("ひゅ" . (h u #t))
    ("ひょ" . (h o #t))
    ("りゃ" . (r a #t))
    ("りゅ" . (r u #t))
    ("りょ" . (r o #t))
    ("じゃ" . (z a #t))
    ("じゅ" . (z u #t))
    ("じぇ" . (z e #t))
    ("じょ" . (z o #t))
    ("ぢゃ" . (d a #t))
    ("ぢゅ" . (d u #t))
    ("ぢぇ" . (d e #t))
    ("ぢょ" . (d o #t))
    ("ぢゃ" . (d a #t))
    ("ぢゅ" . (d u #t))
    ("ぢぇ" . (d e #t))
    ("ぢょ" . (d o #t))
    ("びゃ" . (b a #t))
    ("びゅ" . (b u #t))
    ("びょ" . (b o #t))
    ("ぴゃ" . (p a #t))
    ("ぴゅ" . (p u #t))
    ("ぴょ" . (p o #t))
    ("ぁ" . (l a #t))
    ("ぃ" . (l i #t))
    ("ぅ" . (l u #t))
    ("ぇ" . (l e #t))
    ("ぉ" . (l o #t))
    ("ー" . (#f - #f))))

(define-record-type kana
  (kana cnsnnt vwl gldng)
  kana?
  (cnsnnt consonant set-cnsnnt!)
  (vwl vowel set-vwl!)
  (gldng gliding? set-gldng!))

(define (string->kana-list str)
  (let loop ((lst (string->list str)) (cont identity))
    (if (null? lst)
        (cont '())
        (if (and (not (null? (cdr lst)))
                 (any (lambda (x) (eqv? (cadr lst) x)) (string->list "ゃゅょ")))
            (loop (cddr lst)
                  (lambda (x) (cont (cons (apply kana (cdr (assoc (string (car lst) (cadr lst)) kana-je))) x))))
            (loop (cdr lst)
                  (lambda (x) (cont (cons (apply kana (cdr (assoc (string (car lst)) kana-je))) x))))))))

(define (rassoc value alist)
  (find (lambda (x) (equal? value (cdr x))) alist))

(define (kana->string kana)
  (car (rassoc (list (consonant kana) (vowel kana) (gliding? kana)) kana-je)))

(define (str-map proc str)
  (map proc (string->list str)))