3の倍数と3が付く数字のときだけアホになります(2)

というわけで、作り直してみる。
まずはトップダウンで構成を練る。

仕様は、
・基本的にはふつうにカウントする。
・３の倍数か、３の付く数字ではアホになってカウントする。

関数名をnabe-cntとする。
基本の仕様から考えると、わざわざ関数にしなくても、これはただのリストでも代替できる。
これを関数にする利点は、容量を減らすことと、アクセスがしやすくなることにある。
数字を数えるのは、大体において同じパターンの繰り返しになる。これは、プログラムで実装しやすいタイプの問題である。
1000000000番目をどう言うか知りたいために、そこまでのリストを用意するのはアホらしい*1。

アクセスしやすくするために、次のように結果を呼び出せるようにする。

(nabe-cnt number) -> string #一つ呼び出す。
(nabe-cnt from to) -> list #範囲のリストを呼び出す。
(nabe-cnt from to :output fp) -> IO #出力先を指定する。

さらに、引数なしでヘルプが出ると、実行形式らしくなる。
それはさておき、基本的には最初の方法ができれば、後のは楽であるので、指定された数をどうやって呼び出すかを考える。
指定数でアホになるのはただの切り替えで実装できるが、実際は普通に数えたりするのが難しい。

まず、数字を文字に直す。4桁ごとに区切り、位を表す文字を付ける。
……と、この辺りからボトムアップで進むことにして、プログラムで書いた方が早い。
プログラムは長くなったので畳んでおいた。

実行結果

(nabe-cnt 10000000)
"いっせんまん"

(nabe-cnt 100030000000)
"うぃっすえ〜んおーっくすゎーんずえーんむぁあん"

(nabe-cnt #1=-10 (+ #1# 20) :output t)
まいなすじゅう
むゎいなぁすきゅーう
まいなすはち
まいなすなな
むゎいなぁすりょくぁ
まいなすご
まいなすし
むゎいなぁすすゎーん
まいなすに
まいなすいち
ずぇ〜ろっ
いち
に
すゎーん
し
ご
りょくぁ
なな
はち
きゅーう
おもろー
nil

(nabe-cnt 8904789034908)
"ふあぁーっちぉおうきゅーうすえーんゆぁ〜んぜーうぬぁーなぁおーっくふぁっすえーんきゅーうひゃっくぅすゎーんむぁあんよぉ〜んすえーんきゅーうひゃっくぅふぁっちぁ"

(nabe-cnt 88888811111111)
"はちじゅうはっちょうはっせんはっぴゃくはちじゅうはちおくいっせんひゃくじゅういちまんせんひゃくじゅういち"

(nabe-cnt (exp 10))
"ぬぃいいむぁあんぬぃいいすえーんぬぃいいぜーうりょくぁ"

元ネタは見たことがないので、合ってるか知らないけど、一通り完成ということにする。
アホというより、単に延ばしてるだけな気もするけど。
ともあれ、これで虚構新聞のネタを超えることができるぞｗ

例外の部分はちょこちょこと対応して文字を変えてみる。
濁る部分は前→後、促音便は後→前と相互に影響しているのでややこしい。
まだ千の辺りが怪しい気がするけど、すごくおかしいわけでもないのでＯＫとしておく。
小数や分数は割り切れるとかないので、適当にfloorしてごまかす。一応整数で16桁くらいに対応。
今回は参照してないけど、SKKに、もうちょっとシンプルで使いどころのある数字／漢字変換があるので、それも参考にするといい。

今回の成果

• アナフォリックマクロなんて使わなくても、xyzzy lispには便利なものがあることを覚えた。うーむ、ますますcommon lispが遠ざかる……。
• カーソル移動はループさせてるので、narrow-to-regionが微妙に便利？

コード

(defun nabe-cnt (from &optional to &key output)
  
  (let (hatu)
    (labels
      ((hito (x ahop &optional n)
         (if ahop
             (case x
               (#\1 (if #10=(member n '(3 4)) "うぃーっ" "うぃーちい"))
               (#\2 "ぬぃいい")
               (#\3 "すゎーん")
               (#\4 "ゆぁ〜ん")
               (#\5 "ぐぉお")
               (#\6 "りょくぁ")
               (#\7 "ぬぁーなぁ")
               (#\8 (if #10# "ふあぁーっ" "ふぁっちぁ"))
               (#\9 "きゅーう")
               (t ""))
           (case x
             (#\1 (if #10# "いっ" "いち"))
             (#\2 "に")
             (#\3 "さん")
             (#\4 "し")
             (#\5 "ご")
             (#\6 "ろく")
             (#\7 "なな")
             (#\8 (if #10# "はっ" "はち"))
             (#\9 "きゅう")
             (t ""))))
       (huta (x ahop n c)
         (if x (if ahop
                   (case x
                     (#\0 "")
                     (#\1 #1=(if (and #10# (not c)) "ずぃっ" "ぜーう"))
                     (t (concat (hito x ahop) #1#)))
                 (case x
                   (#\0 "")
                   (#\1 #2=(if (and #10# (not c)) "じっ" "じゅう"))
                    (t (concat (hito x ahop) #2#))))))
       (mitu (x ahop)
         (if x (if ahop
                   (case x
                     (#\0 "")
                     (#\1 #3="ひゃっくぅ")
                     (#\3 (concat (hito x ahop) "びゃぁあく"))
                     (#\4 (concat "ゆぉーん" #3#))
                     (#\6 "るぉーっぴゃぁあーく")
                     (#\8 "ほあっぴゃぁあ〜く")
                     (t (concat (hito x ahop)  #3#)))
                 (case x
                   (#\0 "")
                   (#\1 #4="ひゃく")
                   (#\4 (concat #7="よん" #4#))
                   (#\6 "ろっぴゃく")
                   (#\8 "はっぴゃく")
                   (t (concat (hito x ahop) #4#))))))
       (yotu (x ahop n)
         (if x (if ahop
                   (case x
                     (#\0 "")
                     (#\1 (if (> n 0) "うぃっすえ〜ん" #5="すえーん"))
                     (#\4 (concat "よぉ〜ん" #5#))
                     (#\3 (concat (hito x ahop) "ずえーん"))
                     (#\8 (concat "ふぁっ" #5#))
                     (t (concat (hito x ahop) #5#)))
                 (case x
                   (#\0 "")
                   (#\1 (if (> n 0) "いっせん" #6="せん"))
                   (#\4 (concat #7# #6#))
                   (#\3 (concat (hito x ahop) "ぜん"))
                   (#\8 (concat "はっ" #6#))
                   (t (concat (hito x ahop) #6#))))))
       (keta-d (rev-ls ahop n)
         (concat (yotu (cadddr rev-ls) ahop n)
                 (mitu (caddr rev-ls) ahop)
                 (huta (cadr rev-ls) ahop n (car rev-ls))
                 (hito (car rev-ls) ahop n)))
       (keta-u-sub (lsf n ahop strs)
         (let ((str (keta-d (reverse lsf) ahop n)))
           (concat str (if (equal str "") nil (nth n strs)))))
       (keta-u (lsa n ahop)
         (keta-u-sub lsa n ahop (if ahop
                                    '("" "むぁあん" "おーっく" "ちぉおう" "くうぇえい" "ぐゎあい")
                                  '("" "まん" "おく" "ちょう" "けい" "がい"))))
       (cnt-1-sub (lsb ahop &optional (n 0))
         (concat (if #9=(butlast lsb 4) (cnt-1-sub #9# ahop (1+ n))) (keta-u (last lsb 4) n ahop)))
       (cnt-1-s (num)
         (let* ((n (floor num))
                (lsc (substitute nil #\0 (coerce (format nil "~A" n) 'list)))
                (ahop (and (or (zerop (mod n 3))
                               (member #\3 lsc))
                           t)))
           (if (minusp num)
               (concat (if ahop "もぁいなぁす" "まいなす") (cnt-1-sub (cdr lsc) ahop))
             (cnt-1-sub lsc ahop))))
       (cnt-1 (num)
         (let ((str (cnt-1-s num)))
           (if (equal str "")
               "ずぇ〜ろっ"
             str)))
       (cnt-n (from to)
         (let (lsd (rot (> from to)))
           (when rot (rotatef from to))
           (decf from)
           (while (< (incf from) to)
             (push (cnt-1 from) lsd))
           (if rot lsd (reverse lsd))))
       (out (from &optional to fp)
         (if to
             (long-operation (out-n from to fp))
           (format fp "~A~%" (cnt-1 from))))
       (out-n (from to fp)
         (let ((rot (> from to)))
           (if rot (incf from) (decf from))
           (while (if rot (> (decf from) to) (< (incf from) to))
             (format fp "~A~%" (cnt-1 from))
             (refresh-screen)
             (scroll-window 1)))
         (format fp "おもろー")))
    (if output
        (if (eq t to)
            (out 1 from output)
          (out from to output))
      (if to
          (if (eq t to)
              (cnt-n 1 from)
            (cnt-n from to))
        (cnt-1 from))))))

*1:そこまで数える方がアホらしい？