bf.rkt

#lang racket

(struct bf (program tape pp tp)
  #:transparent
  #:guard (λ (program tape pp tp name)
            (unless (program? program)
              (error name "Not a program ~a" program))
            (unless ((listof exact-integer?) tape)
              (error name "Bad tape ~a" tape))
            (unless (exact-nonnegative-integer? pp)
              (error name "Bad pp ~a" pp))
            (unless (exact-nonnegative-integer? tp)
              (error name "Bad tp ~a" tp))
            (values program tape pp tp)))

(struct program (source)
  #:transparent
  #:guard (λ (source name)
            (unless ((listof char?) source)
              (error name "Bad source ~a" source))
            source))

(define token? (or/c #\+ #\- #\< #\> #\, #\. #\[ #\]))

(define/contract (tokenize ip)
  (input-port? . -> . (listof token?))
  (let loop ([acc '()])
    (define tk (read-char ip))
    (if (eof-object? tk)
        (reverse acc)
        (loop (if (token? tk) (cons tk acc) acc)))))

(define/contract (parse tokens)
  ((listof token?) . -> . program?)
  (define unbalanced
    (let loop ([n 0] [acc tokens])
      (match acc
        [(list #\[ a ...) (loop (add1 n) a)]
        [(list #\] a ...) (loop (sub1 n) a)]
        [(list a b ...) (loop n b)]
        [(list) n])))
  (unless (zero? unbalanced)
    (error 'unbalanced-jump))
  (program tokens))

(define (halted? b)
  (match-define (bf p t pp tp) b)
  (>= pp (length (program-source p))))

(define/contract (step b)
  (bf? . -> . (values bf? boolean?))
  (if (halted? b)
      (values b #f)
      (values
       (match-let* ([(bf p t pp tp) b]
                    [(program src) p])
         (match (list-ref src pp)
           [#\+ (struct-copy bf b [pp (add1 pp)] [tape (list-update t tp add1)])]
           [#\- (struct-copy bf b [pp (add1 pp)] [tape (list-update t tp sub1)])]
           [#\< (struct-copy bf b [pp (add1 pp)] [tp (max (sub1 tp) 0)])]
           [#\> (struct-copy bf b [pp (add1 pp)] [tp (add1 tp)])]
           [#\. (write-byte (list-ref t tp))
                (struct-copy bf b [pp (add1 pp)])]
           [#\, (define by (read-byte))
                (struct-copy bf b [pp (add1 pp)] [tape (list-set t tp (if (eof-object? by) -1 by))])]
           [#\[ (struct-copy bf b [pp (if (not (zero? (list-ref t tp)))
                                          (add1 pp)
                                          (let loop ([n 0] [pp pp])
                                            (unless (< pp (length src))
                                              (error 'runaway-opening-jump))
                                            (define tk (list-ref src pp))
                                            (cond
                                              [(char=? tk #\[) (loop (add1 n) (add1 pp))]
                                              [(char=? tk #\])
                                               (if (= n 1)
                                                   pp
                                                   (loop (sub1 n) (add1 pp)))]
                                              [else (loop n (add1 pp))])))])]
           [#\] (struct-copy bf b [pp (if (zero? (list-ref t tp))
                                          (add1 pp)
                                          (let loop ([n 0] [pp pp])
                                            (unless (>= pp 0)
                                              (error 'runaway-closing-jump))
                                            (define tk (list-ref src pp))
                                            (cond
                                              [(char=? tk #\]) (loop (add1 n) (sub1 pp))]
                                              [(char=? tk #\[)
                                               (if (= n 1)
                                                   pp
                                                   (loop (sub1 n) (sub1 pp)))]
                                              [else (loop n (sub1 pp))])))])]))
       #t)))

(define/contract (run b)
  (bf? . -> . (values bf? exact-nonnegative-integer?))
  (let loop ([n 0] [b b])
    (define-values (bb stepped?) (step b))
    (if stepped?
        (loop (add1 n) bb)
        (values bb n))))