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 >. +. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. +. +. +. +. >. -. |]|
      <. |.| >. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. +. |.|
      +. +. +. +. +. +. +. |.| |.| +. +. +. |.|
      |[| -. |]| >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. |.|
      >. +. +. +. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. +. >. -. |]| <. |.|
      >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. >. -. |]| <. |.|
      +. +. +. |.| -. -. -. -. -. -. |.|
      -. -. -. -. -. -. -. -. |.|
      |[| -. |]| >. +. +. +. +. +. +. +. +.
      |[| <. +. +. +. +. >. -. |]| <. +. |.|
      |[| -. |]| +. +. +. +. +. +. +. +. +. +. |.|))

;; example use of inline brainfuck
;; (run-bf hello-world! 10)