french-number.scm

;
; french-number.scm
; (整数リテラルの suffix の L はおそらく JScheme 限定。
;  crack と map* も JScheme のプロシージャ。ここでの使い方なら
;  それぞれ SRFI-152 の string-split、string->list + map で代用できる。
;  define-macro は多分大抵の処理系にあると思うけど、SRFI-8 のドキュメントに
;  define-syntax による receive の参照実装があります。
;  それ以外の部分は多分ほかの RⁿRS (n≧4) 処理系でも動く。と思ったけど、
;  filter は R⁶RS からだった。SRFI-1 に参照実装があります)
;
; 数とフランス語のアルファベットによる数の文字列表現を相互に変換する。
; convert     : 数を旧正書法の文字列に変換する。
; convert1990 : 数を新正書法の文字列に変換する。
; convert-inv            : 文字列を数に変換する。
; convert-inv-strict     : 旧正書法で書かれた文字列を数に変換する。
; convert-inv-strict1990 : 新正書法で書かれた文字列を数に変換する。
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert （数→文字列）
(define fst17s
  #("zéro" "un" "deux" "trois" "quatre" "cinq" "six" "sept" "huit" "neuf"
    "dix" "onze" "douze" "treize" "quatorze" "quinze" "seize"))

(define mul10s #("" "dix" "vingt" "trente" "quarante" "cinquante" "soixante"))

(define (convert<17 n) (vector-ref fst17s n))
(define convert<10 convert<17)

(define (convert<70 n)
  (if (< n 17) (convert<17 n)
    (let ((qth (vector-ref mul10s (quotient n 10))) (r (modulo n 10)))
      (cond ((= r 0) qth) ((= r 1) (string-append qth " et un"))
            (else (string-append qth "-" (convert<10 r)))))))

(define convert<20 convert<70)

(define (convert<80 n)
  (if (< n 70) (convert<70 n)
    (string-append (vector-ref mul10s 6) (if (= n 71) " et " "-")
                   (convert<20 (- n 60)))))

(define (convert<100 n . singular?)
  (define name-of-80 (string-append (convert<10 4) "-" (convert<70 20)))

  (cond ((< n 80) (convert<80 n))
        ((= n 80) (if (and (pair? singular?) (car singular?)) name-of-80
                    (string-append name-of-80 "s")))
        (else (string-append name-of-80 "-" (convert<20 (- n 80))))))

(define (convert<1000 n . singular?)
  (define (conv<100 n) (apply convert<100 n singular?))
  (define (convert-q*100 q)
    (if (= q 1) "cent" (string-append (convert<10 q) " cent")))

  (if (< n 100) (conv<100 n)
    (let ((q (quotient n 100)) (r (modulo n 100)))
      (if (= r 0)
        (if (or (and (pair? singular?) (car singular?)) (= q 1))
          (convert-q*100 q)
          (string-append (convert-q*100 q) "s"))
        (string-append (convert-q*100 q) " " (conv<100 r))))))

(define (convert<10^6 n)
  (if (< n 1000) (convert<1000 n)
    (let* ((q (quotient n 1000)) (r (modulo n 1000))
           (str-q*1000 (if (= q 1)
                         "mille"
                         (string-append (convert<1000 q #t) " mille"))))
      (if (= r 0) str-q*1000 (string-append str-q*1000 " " (convert<1000 r))))))

(define %10^6 1000000)
(define (convert<10^9 n)
  (if (< n %10^6) (convert<10^6 n)
    (let* ((q (quotient n %10^6)) (r (modulo n %10^6))
           (str-q*10^6 (string-append (convert<1000 q)
                                      (if (= q 1) " million" " millions"))))
      (if (= r 0) str-q*10^6 (string-append str-q*10^6 " " (convert<10^6 r))))))


(define %10^9 1000000000L)
(define (convert<10^12 n)
  (if (< n %10^9) (convert<10^9 n)
    (let* ((q (quotient n %10^9)) (r (modulo n %10^9))
           (str-q*10^9 (string-append (convert<1000 q)
                                      (if (= q 1) " milliard" " milliards"))))
      (if (= r 0) str-q*10^9 (string-append str-q*10^9 " " (convert<10^9 r))))))

(define %10^12 1000000000000L)
(define (convert<10^18 n)
  (if (< n %10^12) (convert<10^12 n)
    (let* ((q (quotient n %10^12)) (r (modulo n %10^12))
           (str-q*10^12 (string-append (convert<10^6 q)
                                       (if (= q 1) " billion" " billions"))))
      (if (= r 0) str-q*10^12
        (string-append str-q*10^12 " " (convert<10^12 r))))))

(define %10^18 1000000000000000000L)
(define (convert<10^24 n)
  (if (< n %10^18) (convert<10^18 n)
    (let* ((q (quotient n %10^18)) (r (modulo n %10^18))
           (str-q*10^18 (string-append (convert<10^6 q)
                                       (if (= q 1) " trillion" " trillions"))))
      (if (= r 0) str-q*10^18
        (string-append str-q*10^18 " " (convert<10^18 r))))))

; (convert 80080) => "quatre-vingt mille quatre-vingts"
; (convert1990 80080) => "quatre-vingt-mille-quatre-vingts"
(define convert convert<10^24)
(define (space->hyphen s)
  (list->string (map* (lambda (c) (if (char-whitespace? c) #\- c)) s)))
(define (convert1990 n) (space->hyphen (convert n)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert-inv （文字列→数）
;; 文字列の後ろに数を表すのに使われない単語が続いていてもよい。
(define-macro (receive formals expression . body)
  `(call-with-values (lambda () ,expression) (lambda ,formals . ,body)))

(define fst17s-inv
  (let recur ((i 0))
    (if (>= i (vector-length fst17s)) '()
      `((,(vector-ref fst17s i) . ,i) . ,(recur (+ i 1))))))

(define mul10s-inv
  (let recur ((i 0))
    (if (>= i (vector-length mul10s)) '()
      `((,(vector-ref mul10s i) . ,(* 10 i)) . ,(recur (+ i 1))))))

(define (convert-inv<100 lis)
  (cond ((null? lis) (values 0 '()))
        ((string=? (car lis) "quatre")
         (cond ((null? (cdr lis)) (values 4 '()))
               ((string=? (cadr lis) "vingts") (values 80 (cddr lis)))
               ((string=? (cadr lis) "vingt")
                (receive (val rest) (convert-inv<100 (cddr lis))
                  (values (+ 80 val) rest)))
               (else (values 4 (cdr lis)))))

        (else (let ((maybe-n*10 (assoc (car lis) mul10s-inv)))
                (if maybe-n*10
                  (receive (val rest) (convert-inv<100 (cdr lis))
                    (values (+ (cdr maybe-n*10) val) rest))
                  (let ((maybe-in-fst17s (assoc (car lis) fst17s-inv)))
                    (cond (maybe-in-fst17s
                           (values (cdr maybe-in-fst17s) (cdr lis)))
                          ((string=? (car lis) "une") (values 1 (cdr lis)))
                          (else (values 0 lis)))))))))

(define (convert-inv<1000 lis)
  (receive (val rest) (convert-inv<100 lis)
    (cond ((null? rest) (values val '()))
          ((string=? (car rest) "cents") (values (* val 100) (cdr rest)))
          ((string=? (car rest) "cent")
           (receive (val2 rest) (convert-inv<100 (cdr rest))
             (values (+ (if (= val 0) 100 (* val 100)) val2)
                     rest)))
          (else (values val rest)))))

(define (convert-inv<10^6 lis)
  (receive (val rest) (convert-inv<1000 lis)
    (if (and (pair? rest) (string=? (car rest) "mille"))
      (receive (val2 rest) (convert-inv<1000 (cdr rest))
        (values (+ (if (= val 0) 1000 (* val 1000)) val2)
                rest))
      (values val rest))))

(define (convert-inv<10^24 lis)
  (receive (val rest) (convert-inv<10^6 lis)
    (cond ((null? rest) (values val '()))
          ((member (car rest) '("million" "millions"))
           (receive (val2 rest) (convert-inv<10^6 (cdr rest))
             (values (+ (* val %10^6) val2) rest)))
          ((member (car rest) '("milliard" "milliards"))
           (receive (val2 rest) (convert-inv<10^24 (cdr rest))
             (values (+ (* val %10^9) val2) rest)))
          ((member (car rest) '("billion" "billions"))
           (receive (val2 rest) (convert-inv<10^24 (cdr rest))
             (values (+ (* val %10^12) val2) rest)))
          ((member (car rest) '("trillion" "trillions"))
           (receive (val2 rest) (convert-inv<10^24 (cdr rest))
             (values (+ (* val %10^18) val2) rest)))
          (else (values val rest)))))

(use-module "elf/iterate.scm")
(define (convert-inv+ s)
  (convert-inv<10^24
    (filter (lambda (s) (not (string=? s "et")))
            (crack (list->string (map* char-downcase s)) "- \n\t"))))
(define (convert-inv s) (receive (res rest) (convert-inv+ s) res))

(define (%convert-inv-strict s conv)
  (let* ((res (convert-inv s)) (s2 (conv res)) (len (string-length s2)))
    (if (and (<= len (string-length s))
             (char-ci=? (string-ref s 0) (string-ref s2 0))
             (string=? (substring s 1 len) (substring s2 1 len)))
      res
      #f)))

(define (convert-inv-strict     s) (%convert-inv-strict s convert))
(define (convert-inv-strict1990 s) (%convert-inv-strict s convert1990))

;; convert-inv-strict は convert が返す文字列と完全に同じ文字列を先頭部分に持つ
;; 文字列しか許容しない。許容範囲を広げたい場合、許容したい文字列を convert が返
;; す形式に書き換えるという方法が考えられる。unique-delimiter はそのための書き換
;; えプロシージャの一例である。
;; (convert-inv-strict "neuf  cent") => #f
;; (convert-inv-strict (unique-delimiter "neuf  cent")) => 900
(define (unique-delimiter s)
  (do ((i (- (string-length s) 2) (- i 1))
       (dst `(,(string-ref s (- (string-length s) 1)))
            (let ((c (string-ref s i)))
              (cond ((char=? c #\-)
                     `(,c . ,(if (char-whitespace? (car dst)) (cdr dst) dst)))
                    ((char-whitespace? c)
                     (if (memv (car dst) '(#\- #\space)) dst `(#\space . ,dst)))
                    (else `(,c . ,dst))))))
      ((< i 0) (list->string (if (char-whitespace? (car dst)) (cdr dst) dst)))))