(import (rnrs base)
(rnrs records syntactic)
(rnrs io simple))
;; The state is defined as a zipper with three fields
;; - left: cells to the left of current cell, in reverse order
;; - current: the current cell
;; - right: cells to the right of current cell
;; This structure allows for a purely functional implementation that
;; supports all Brainfuck primitives in O(1) time.
(fields left current right))
;; In an initial state there are no cells to the left, since we are
;; at the beginning of the tape. The current cell is zero. We don't
;; need to allocate cells on the right, since they are lazily created
;; as needed (see move-right).
(make-state '() 0 '()))
;; Moves to the left on the tape; it is an error to go past the left edge.
(define (move-left s)
(let ([left (state-left s)])
(if (null? left)
(error "can't move to left")
(make-state (cdr left)
(cons (state-current s) (state-right s))))))
;; Moves to the right on the tape, allocating more space if necessary.
(define (move-right s)
(define (normalize p)
(if (null? p) (list 0) p))
(let ([right (normalize (state-right s))])
(make-state (cons (state-current s) (state-left s))
;; Returns a new state where the current element has been transformed
;; with given function.
(define (modify-current f s)
(make-state (state-left s) (f (state-current s)) (state-right s)))
(define (increase s)
(modify-current (lambda (v) (+ v 1)) s))
(define (decrease s)
(modify-current (lambda (v) (- v 1)) s))
(define (nop s) s)
(define (display-current s)
(display (integer->char (state-current s)))
(define (read-into-current s)
(make-state (state-left s)
;; Given a lexer, parses a Brainfuck program into an abstract syntax tree.
;; The given lexer can be any function which either returns next character
;; or eof-object when called without arguments.
(define (parse lexer)
(let ([ch (lexer)])
(if (eof-object? ch)
[(#\+) (cons '(increase) (parse-exps))]
[(#\-) (cons '(decrease) (parse-exps))]
[(#\>) (cons '(move-right) (parse-exps))]
[(#\<) (cons '(move-left ) (parse-exps))]
[(#\.) (cons '(display) (parse-exps))]
[(#\,) (cons '(read) (parse-exps))]
[(#\[) (let* ([loop (parse-exps)]
(cons (cons 'loop loop) rest))]
;; Transforms parsed AST into an analyzed representation, which
;; is faster to execute. The result is a function representing
;; the program: the function can be called with the initial state
;; of the machine and will return the final state after stopping.
(define (analyze-program e)
;; analyze a list of expressions and produce a single
;; expression which evaluates all sub-expressions in sequence
(define (analyze-seq p)
(if (null? p)
(let ([first (analyze-exp (car p))])
(if (null? (cdr p))
(let ([rest (analyze-seq (cdr p))])
(lambda (s) (rest (first s))))))))
(define (analyze-loop p)
(let ([body (analyze-seq p)])
(let loop ([s s])
(if (zero? (state-current s))
(loop (body s)))))))
;; analyzes single expression
(define (analyze-exp p)
(case (car p)
[(loop) (analyze-loop (cdr p))]
[else (error "invalid form -- " p)]))
;; Creates a lexer from given string.
(define (string->lexer s)
(list->lexer (string->list s)))
;; Creates a lexer from given list of characters.
(define (list->lexer input)
(if (null? input)
(let ([ch (car input)])
(set! input (cdr input))
;; Parses, analyzes and executes the program provided by given lexer.
(define (run lexer)
(let* ([exp (parse lexer)]
[analyzed (analyze-program exp)])