Skip to content

Instantly share code, notes, and snippets.

@athos
Created November 21, 2010 03:37
Show Gist options
  • Save athos/708422 to your computer and use it in GitHub Desktop.
Save athos/708422 to your computer and use it in GitHub Desktop.
;; 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment