インライン Brainfuck をモナドっぽいなにかで

タイトルは釣り気味？なんとなくStateモナドのつもりで書いていたけど、これをモナドと呼ぶのかは謎。

メインのアイディアは、Brainfuck の各命令を関数で表し、メモリやポインタといった Brainfuck の実行に必要な状態を引き渡していくというもの。

つまり、こんな Brainfuck のコードを

 + + [ < + + > - ]

こんな感じで表す。

(|]| (- (> (+ (+ (< (|[| (+ (+ 初期状態)))))))))

ちなみに、Scheme では "[", "]", ",", "." といった識別子は普通には使えないので、ここでは "|"(パイプ) で囲って "|[|" のようにして使っている。

ただ、これだとコードの順序が逆になるので、

(define (>> x f)
  (lambda (s)
    (let ([s* (x s)])
      (f s*))))

(define-syntax do
  (syntax-rules ()
    [(_ command) command]
    [(_ command commands ...)
     (>> command (do commands ...))]))

として、

((do + + |[| < + + > - |]|) 初期状態)

と書けるようにしている。

Brainfuck の各命令を関数で表そうと思ったとき、"+" や ">" といった命令は簡単に実装できる。問題となるのは "[" と "]" で、それぞれ別の方法で実現している。

まず、"[" から対応する "]" にジャンプする場合は、ある種のフラグを立てておいて、そのフラグが立っている間は "+" や "<" といった通常の命令は何もせず状態をそのまま受け流すようにする。実際には、"[" や "]" はネストできるので単なるフラグではなくて、ネストの深さも見る必要がある。

"]" から対応する "[" にジャンプする場合には継続を使う。継続を積むためのスタックを状態としてもつようにして、"[" に入るごとに継続を捕捉し、その継続のスタックに捕捉した継続をプッシュする。そうすると、"]" でジャンプするときには、スタックのトップにある継続を呼び出してやるだけでいい。

以下、ソースコード。ポータブルなコードにするために、やや冗長に書いている。

brainfuck.scm

;; delayed tree structure for representing brainfuck's ``memory''
(define (make-tree n)
  (define (rec start n)
    (delay
      (if (= n 1)
        0
        (let* ([n/2 (ceiling (/ n 2))]
               [n-n/2 (- n n/2)])
          (list (- n/2 1) (rec start n/2) (rec (+ start n/2) n-n/2))))))
  (rec 0 n))

(define (get t n)
  (let ([t (force t)])
    (if (list? t)
      (if (<= n (car t))
        (get (cadr t) n)
        (get (caddr t) n))
      t)))

(define (update t n f)
  (delay
    (let ([t (force t)])
      (if (list? t)
        (if (<= n (car t))
          (list (car t) (update (cadr t) n f) (caddr t))
          (list (car t) (cadr t) (update (caddr t) n f)))
        (f t)))))

;; for debug
(define (tree->list t)
  (let ([t (force t)])
    (if (list? t)
      (append (tree->list (cadr t))
              (tree->list (caddr t)))
      (list t))))

(define-syntax receive
  (syntax-rules ()
    [(_ args expr body ...)
     (call-with-values (lambda () expr)
       (lambda args body ...))]))

;; monadic stuffs
(define (>> x f)
  (lambda (m p c d)
    ;(print #`",(tree->list m) ,p ,c ,d")
    (receive (m* p* c* d*) (x m p c d)
      (f m* p* c* d*))))

(define-syntax do
  (syntax-rules ()
    [(_ command) command]
    [(_ command commands ...)
     (>> command (do commands ...))]))

;; driver
(define (run-bf x n)
  (receive (m p c d)
      (x (make-tree n) 0 '() 0)
    (if (or (not (null? c))
            (not (= d 0)))
      (error "unexpected EOF"))
    m))

;; utilities for defining actions
(define (with-depth-checked f)
  (lambda (memory pointer cont depth)
    (if (= depth 0)
      (receive (m p) (f memory pointer)
        (values m p cont depth))
      (values memory pointer cont depth))))

(define (standard-insn f g)
  (with-depth-checked
    (lambda (memory pointer)
      (values (update memory pointer f) (g pointer)))))

(define id (lambda (x) x))

(define (inc n)
  (+ n 1))

(define (dec n)
  (- n 1))

;; definitions of actions
(define >. (standard-insn id inc))
(define <. (standard-insn id dec))
(define +. (standard-insn inc id))
(define -. (standard-insn dec id))

(define |,|
  (with-depth-checked
    (lambda (m p)
      (let ([v (char->integer (read-char))])
        (values (update m p (lambda (_) v)) p)))))

(define |.|
  (with-depth-checked
    (lambda (m p)
      (let ([c (integer->char (get m p))])
        (write-char c)
        (values m p)))))

(define (|[| m p c d)
  (if (= d 0)
    (if (= (get m p) 0)
      (values m p c (inc d))
      (receive (m* p* c*) 
          (call/cc
            (lambda (k)
              (values m p (cons k c))))
        (values m* p* c* d)))
    (values m p c (inc d))))

(define (|]| m p c d)
  (if (null? c)
    (error "extra close bracket"))
  (if (= d 0)
    (if (= (get m p) 0)
      (values m p (cdr c) d)
      ((car c) m p c))
    (values m p c (dec d))))

;; example
(define hello-world!
  (do >. +. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. +. +. +. +. >. -. |]|
      <. |.| >. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. +. |.|
      +. +. +. +. +. +. +. |.| |.| +. +. +. |.|
      |[| -. |]| >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. |.|
      >. +. +. +. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. +. >. -. |]| <. |.|
      >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. >. -. |]| <. |.|
      +. +. +. |.| -. -. -. -. -. -. |.|
      -. -. -. -. -. -. -. -. |.|
      |[| -. |]| >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. +. |.|
      |[| -. |]| +. +. +. +. +. +. +. +. +. +. |.|))

ちなみに、"+", "-", ">", "<" という識別子は Scheme としては使えるのだけど、これらを Brainfuck の命令として使うと、組込みの関数を上書きしてしまうことになるため、ここではそれぞれ "+.", "-.", ">.", "<." を使っている(Gauche の場合は、"+." や "-." でも組込み関数を上書きしてしまうことにはなるけど)。

run-bf という関数に Brainfuck のコードと使用するメモリのサイズを渡すと Brainfuck のコードが実行され、終状態でのメモリが返ってくる。

実行例は下のようになる。

gosh> (tree->list (run-bf (do +. >. +. +. >. +. +. +.) 3))
(1 2 3)
gosh> (tree->list (run-bf hello-world! 3))
Hello World!
(10 0 0)
gosh>

というわけで、インラインで Brainfuck が書けるようになったので、次回インラインWhitespaceの実装にご期待下さい(嘘