CLのformatで(?)brainf*ck
ChatonのCL部屋にてCL勉強会が復活されるとのことなので、
今回のテーマ『format』を使ったプログラムを書いてみました(コードはエントリの末尾)。
> (eval-brainf*ck "+++++++++ [>++++++++>+++++++++++>+++++<<<-] >.>++.+++++++..+++.>-.------------.< ++++++++.--------.+++.------.--------.>+.") Hello, world! NIL
もともとは、shiroさんの
「~?で自分自身を読むことを許した場合、Turing completeになったりしないかなあ」
というアイディアをお借りして何か作れないかと思ったんですが、
formatだけで「何かを記憶する」という方法が思いつかず、
結局 ~/…/ に頼るプログラムになってしまいました。
(~/name/ 指定子を使うとformatの中で関数nameを呼び出せます。)
formatに直接brainf*ckのコードを文字列で渡すのではなく、
まず、コードを文字列からリストに変換するんですが、
このリスト、入れ子構造を持ってたり、循環構造まで持ってたりします。
本当はformatだけで頑張りたかったんですが、私の力不足で、
formatに渡す前に頑張るという変なプログラムになってしまいました。
見所は、循環リストの中で ~? を使って、ループを実現しているところくらいですかね。
(defvar *brainf*ck-evaluator* "~
~{~
~[~
~:*~/format-bf-mov/~;~
~:*~:/format-bf-mov/~;~
~:*~/format-bf-cal/~;~
~:*~:/format-bf-cal/~;~
~:*~/format-bf-io/~;~
~:*~:/format-bf-io/~;~
~/format-bf-loop/~:*~
~{~
~:[~
~*~;~
~:*~?~
~]~
~}~
~]~
~}")
(let ((pointer 0)
(array (make-array #1=10
:element-type 'fixnum
:initial-element 0
:adjustable t
:fill-pointer #1#)))
(defun bf-data-reset ()
(setf pointer 0)
(setf (fill-pointer array) 1)
(setf (aref array 0) 0))
(defun format-bf-mov (stream arg colon-p at-p &rest args)
(declare (ignore stream arg at-p args))
(incf pointer (if colon-p -1 1))
(when (>= pointer (fill-pointer array))
(vector-push-extend 0 array)))
(defun format-bf-cal (stream arg colon-p at-p &rest args)
(declare (ignore stream arg at-p args))
(incf (aref array pointer) (if colon-p -1 1)))
(defun format-bf-io (stream arg colon-p at-p &rest args)
(declare (ignore stream arg at-p args))
(if colon-p
(setf (aref array pointer) (char-code (read-char)))
(princ (code-char (aref array pointer)))))
(defun format-bf-loop (stream arg colon-p at-p &rest args)
(declare (ignore stream colon-p at-p args))
(if (= (aref array pointer) 0)
(setf (first arg) nil)
(setf (first arg) *brainf*ck-evaluator*))))
(defun decode-brainf*ck (char)
(case char
(#¥> 0)
(#¥< 1)
(#¥+ 2)
(#¥- 3)
(#¥. 4)
(#¥, 5)
(#¥[ 6)
(#¥] 7)))
(defun compile-brainf*ck (str &optional (start 0))
(do ((i start (1+ i))
acc)
((or (>= i (length str)) (char= (aref str i) #¥]))
(values (nreverse acc) i))
(push (decode-brainf*ck (aref str i)) acc)
(when (char= (aref str i) #¥[)
(multiple-value-bind (code new-i)
(compile-brainf*ck str (1+ i))
(let ((code1 (list nil (list (copy-list code))))
(code2 (list (decode-brainf*ck #¥[)
(list nil (list (copy-list code))))))
(nconc (car (second (second code2))) code2)
(nconc (car (second code1)) code2)
(push code1 acc)
(setf i new-i))))))
(defun eval-brainf*ck (str)
(bf-data-reset)
(format t
*brainf*ck-evaluator*
(compile-brainf*ck str)))