LISP: '$e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E

ひたすら「e」が並んでいるだけのリポジトリが話題になってました。

github.com

Lispはどうかと見てみると、シンプルに無限ループで面白いというのが初見の感想でした。

e.lisp

(loop (print "e"))

しかし、ここでC言語の実装を見てみると何やら面白いことをしているではありませんか。

e.c

#include <stdio.h>
#define e "e"
#define ee int
#define eee main
#define eeee (
#define eeeee )
#define eeeeee {
#define eeeeeee }
#define eeeeeeee for
#define eeeeeeeee ;
#define eeeeeeeeee printf
#define eeeeeeeeeee return
#define eeeeeeeeeeee on_exit
#define eeeeeeeeeeeee [
#define eeeeeeeeeeeeee ]
#define eeeeeeeeeeeeeee 0

ee eee eeee eeeee eeeeee eeeeeeee eeee eeeeeeeee
eeeeeeeee eeeee eeeeee eeeeeeeeee eeee e eeeee
eeeeeeeee eeeeeee eeeeeee ee eeeeeeeeeeee eeee
eeeee eeeeee eeeeeeeeeee e eeeeeeeeeeeee
eeeeeeeeeeeeeee eeeeeeeeeeeeee eeeeeeeee eeeeeee

これを見ていると、Cでこんな頑張っているのになんだあのLispは、エイリアン分が足りないのではないかという気分になってきました。

ということで書き換えてみました。(loop (print "e"))と等価なコードです。

(make-dispatch-macro-character #\$)

(set-dispatch-macro-character
 #\$ #\e
 (lambda (stream &rest rest)
   (declare (ignore rest))
   (let ((count 0)
         (char-list nil))
     (do ((char #1=(read-char stream) #1#))
         ((eq char #\E)
          (intern (coerce (nreverse char-list) 'string)))
       (case char
         (#\  (when (> count 0)
                (push (code-char (+ count (char-code #\0)))
                      char-list)
                (setf count 0)))
         (#\e (incf count)))))))

($e eeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E
  ($e eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeee eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee E "e"))

そうリーダーマクロです。$eEまでが1つのシンボルに対応します。下の例を見るのが分かり易いと思いますが、スペース区切りで連続した「e」の個数を数えて、個数に応じたASCII文字に変換するという単純なアイディアです。なお、文字コードの「0」= 48個上乗せはうっとうしいので、「0」をオフセットにしています。

eeeeeeeeeeeeeeeeeeeeeeeeeeee     → eが28個 → '0' + 28 → 'L'
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee  → eが31個 → '0' + 31 → 'O'
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeee  → eが31個 → '0' + 31 → 'O'
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee → eが32個 → '0' + 32 → 'P'
↓
LOOP

カッコも「e」にしてしまいたいところですが、面倒なのでそれは置いておき…

'$a 工工エェェ(゚Д゚)ェ工 工工エェ(゚Д゚)工 工ェ(゚Д゚)工 工工ェェ(゚Д゚)ェ工 工エェ(゚Д゚)工 A

おまけです。

さて、日本語で「e」=「え」が沢山並ぶものというと、個人的にはまず次のAAが思い浮かびます。

工工工エエエエエエェェェェェェ(゚Д゚)ェェェェェェエエエエエエ工工工

これを活用してみます。やることは単純で、上記の「e」で1ずつカウントしていたものを、次のようなカウント方式に変更するだけです。

  • 「(゚Д゚)」: 48個分 (※48 = '0')
  • 「工」: 8個分
  • 「エ」: 4個分
  • 「ェ」: 1個分
(make-dispatch-macro-character #\$)

(defun integer-string-p (str)
  (multiple-value-bind (parsed count)
      (parse-integer str :junk-allowed t)
    (and parsed (= (length str) count))))

;; ※ついでに数値も扱えるようにしておく
(defun my-intern (str)
  (if (integer-string-p str)
      (parse-integer str)
      (intern str)))

(set-dispatch-macro-character
 #\$ #\a
 (lambda (stream &rest rest)
   (declare (ignore rest))
   (let ((count 0)
         (char-list nil))
     (do ((char #1= (read-char stream) #1#))
         ((eq char #\A)
          (my-intern (coerce (nreverse char-list) 'string)))
       (case char
         (#\  (when (> count 0)
                (push (code-char count)
                      char-list)
                (setf count 0)))
         (#\( (if (and (eq (read-char stream) #\゚)
                       (eq (read-char stream) #\Д)
                       (eq (read-char stream) #\゚)
                       (eq (read-char stream) #\) ))
                  (incf count 48)
                  (error "Not allowed AA")))
         (#\工 (incf count 8))
         (#\エ (incf count 4))
         (#\ェ (incf count 1)))))))

このリーダーマクロを利用することで、(loop (print "e"))は次のように書けます。…文字列の扱いはちょっとサボってます。

($a 工工エ(゚Д゚)工 工工エェェ(゚Д゚)ェ工 工工エェェ(゚Д゚)ェ工 工工(゚Д゚)工工 A
  ($a 工工(゚Д゚)工工 工工ェ(゚Д゚)ェ工工 工工ェ(゚Д゚)工 工工エェ(゚Д゚)ェ工 工工エ(゚Д゚)工工 A "e"))

せっかくなので、あの有名な再帰関数を書いてみます。

($a 工エ(゚Д゚)工 工エェ(゚Д゚)工 工エェ(゚Д゚)ェ工 工工エェ(゚Д゚)工工 工工エェ(゚Д゚)ェ工 A $a 工エェ(゚Д゚)ェ工 工工ェ(゚Д゚)工 工ェ(゚Д゚)ェ工 A
    ($a 工工エェ(゚Д゚)ェ工 A )
  ($a 工ェェ(゚Д゚)ェ工 工ェ(゚Д゚)工 工工ェェ(゚Д゚)ェ工工 工エェ(゚Д゚)工 A
      $a 工工エェ(゚Д゚)ェ工 A
    ($a (゚Д゚) A $a (゚Д゚) A )
    (($a ェ(゚Д゚) A $a ェ(゚Д゚)ェ A )$a ェ(゚Д゚) A )
    ($a 工工エ(゚Д゚)工工 A
      ($a 工工工ェェェ工工 A ($a 工エェ(゚Д゚)ェ工 工工ェ(゚Д゚)工 工ェ(゚Д゚)ェ工 A
                             ($a 工工工エェ工工 A $a 工工エェ(゚Д゚)ェ工 A $a ェ(゚Д゚) A ))
                           ($a 工エェ(゚Д゚)ェ工 工工ェ(゚Д゚)工 工ェ(゚Д゚)ェ工 A
                             ($a 工工工エェ工工 A $a 工工エェ(゚Д゚)ェ工 A $a ェ(゚Д゚)ェ A ))))))

動かしてみます。

CL-USER> ($a 工エ(゚Д゚)工 工工エェェ(゚Д゚)ェ工 工工エ(゚Д゚)工工 工工ェ(゚Д゚)工 工工エェ(゚Д゚)工 工エェ(゚Д゚)工 工工ェェ(゚Д゚)ェ工工 A ($a 工工ェ(゚Д゚)工 A $a ェ(゚Д゚) (゚Д゚) A )
             ($a 工工(゚Д゚)工工 工工ェ(゚Д゚)ェ工工 工工ェ(゚Д゚)工 工工エェ(゚Д゚)ェ工 工工エ(゚Д゚)工工 A
                 ($a 工エェ(゚Д゚)ェ工 工工ェ(゚Д゚)工 工ェ(゚Д゚)ェ工 A $a 工工ェ(゚Д゚)工 A )))

0
1
1
2
3
5
8
13
21
34
NIL

そうフィボナッチ関数です。

;; インデント合わせ版
(defun fib
    (n)
  (case n
    (0 0)
    ((1 2) 1)
    (t
     (+ (fib
         (- n 1))
        (fib
         (- n 2))))))

;; 普通にインデント版
(defun fib (n)
  (case n
    (0 0)
    ((1 2) 1)
    (t (+ (fib (- n 1))
          (fib (- n 2))))))

なお、動作確認は次のように行いました。

(dotimes (i 10)
  (print
    (fib i)))

'$a 工工(゚Д゚)工 工工エェェ(゚Д゚)ェ工 工工ェェ(゚Д゚)ェ工工 工工エェェ(゚Д゚)ェ工 工工ェェ(゚Д゚)ェ工 工工エェ(゚Д゚)工工 A

補足です。

さすがに手で書きくだすのは辛いので、次のような convert-tree-to-aa 関数を書いて変換しています。1行目がprincの出力ですので、これをコピペします。

CL-USER> (convert-tree-to-aa '(loop (print "e")))
($a 工工エ(゚Д゚)工 工工エェェ(゚Д゚)ェ工 工工エェェ(゚Д゚)ェ工 工工(゚Д゚)工工 A ($a 工工(゚Д゚)工工 工工ェ(゚Д゚)ェ工工 工工ェ(゚Д゚)工 工工エェ(゚Д゚)ェ工 工工エ(゚Д゚)工工 A "e"))
"($a 工工エ(゚Д゚)工 工工エェェ(゚Д゚)ェ工 工工エェェ(゚Д゚)ェ工 工工(゚Д゚)工工 A ($a 工工(゚Д゚)工工 工工ェ(゚Д゚)ェ工工 工工ェ(゚Д゚)工 工工エェ(゚Д゚)ェ工 工工エ(゚Д゚)工工 A \"e\"))"

一応同関数の実装です。

(ql:quickload :alexandria)

(defun multi-mod (value mod-list)
  "各パーツがどれだけ必要かを計算する"
  ;; (multi-mod 9 '(2 1)) -> (4 1) :: 9 -> 4 * 2 + 1 * 1
  (labels ((rec (rest-value rest-mod-list result)
             (if rest-mod-list
                 (let ((modular (car rest-mod-list)))
                   (rec (mod rest-value modular)
                        (cdr rest-mod-list)
                        (cons (floor (/ rest-value modular)) result)))
                 (values (nreverse result) rest-value))))
    (rec value (sort mod-list #'>) nil)))

(defun concat-string-list (str-list)
  (apply #'concatenate `(string ,@str-list)))

(defun sort-string (str-list count-list)
  "必要個数に応じてパーツを良い感じに並べる"
  ;; (sort-string '("Z" "a") '(4 2)) -> ("Z" "Z" "a" "a" "Z" "Z")
  (assert (= (length str-list) (length count-list)))
  (let ((split-count-list
         (mapcar (lambda (count)
                   (cons (ceiling (/ count 2))
                         (floor (/ count 2))))
                 count-list)))
    (flet ((collect-string (target-str-list place)
             (apply #'append
                    (loop
                       :for str :in target-str-list
                       :for count :in (mapcar place split-count-list)
                       :collect (loop :for i :from 0 :below count
                                   :collect str)))))
      (concat-string-list
       (append (collect-string str-list #'car)
               (reverse (collect-string str-list #'cdr)))))))

(defvar *mod-list* '(48 8 4 1))

(defun convert-to-aa (str)
  "文字列をAAに変換する"
  ;; (convert-to-aa "012") -> "(゚Д゚) ェ(゚Д゚) ェ(゚Д゚)ェ "
  (format nil "~{~A ~}"
          (mapcar (lambda (count-list)
                    (sort-string '("工" "エ" "ェ" "(゚Д゚)")
                                 count-list))
                  (mapcar (lambda (char)
                            (alexandria:rotate (multi-mod (char-code char) *mod-list*)
                                               -1))
                          (coerce str 'list)))))

(defun convert-tree-to-aa (form)
  "完成品: 木をたどって(文字列以外の)全ての要素をAA化する"
  (labels ((rec (rest-form)
             (if (listp rest-form)
                 (format nil "(~{~A~})"
                         (mapcar (lambda (form)
                                   (rec form))
                                 rest-form))
                 (typecase rest-form
                   (string (format nil "\"~A\"" rest-form))
                   (t (format nil "$a ~AA "
                              (convert-to-aa (write-to-string rest-form))))))))
    (princ (rec form))))

'$a 工工エェェ(゚Д゚)ェ工 工工エェェ(゚Д゚)ェ工工 工ェ(゚Д゚)工 工工ェ(゚Д゚)ェ工工 工工ェ(゚Д゚)工 A