DrBrainf-ck/interpreter.rkt

#lang racket

; 2018-11-21 - Made by Claudio Maggioni - Tommaso Rodolfo Masera
; easybf

(require racket/base
         racket/struct
         test-engine/racket-tests)

(provide prog-state
         prog-state?
         prog-state-tape
         prog-state-dp
         prog-state-output
         prog-state-program
         prog-state-ip
         execute
         string->program
         program->prog-state)

; A Byte is an Int between 0 and 255
; Interpretation: a byte in decimal notation.

; A Tape is a NEList<Byte>
; Interpretation: a tape in brainf*ck's Turing machine.

; A DataPointer (DP) is a NonNegInt
; Interpretation: a data pointer in the brainf*ck language in a tape.

; A Program is a String of:
; - ">" (tape-right)
; - "<" (tape-left)
; - "+" (add1)
; - "-" (sub1)
; - "." (out)
; - ","
; - "[" (loop-start)
; - "]" (loop-end)
; Interpretation: the brainf*ck program.

; A InstructionPointer (IP) is a NonNegInt
; Interpretation: a pointer to the instruction to execute.

; A ProgState is a (prog-state tape dp output program ip) where:
; - tape: Tape
; - dp: DataPointer
; - tape-len: Nat
; - output: String
; - program: Program
; - ip: InstructionPointer
; Interpretation: the current state of execution of a brainf*ck program.
(struct prog-state (tape dp tape-len output program ip)
  #:transparent
  #:methods gen:custom-write
  [(define write-proc
     (make-constructor-style-printer
      (lambda (w) 'ProgState)
      (lambda (w) (list (prog-state-tape w)
                        (prog-state-dp w)
                        (prog-state-tape-len w)
                        (prog-state-output w)
                        (prog-state-program w)
                        (prog-state-ip w)))))])

; Template function for ProgState
#;(define (fn-for-prog-state w)
#;  (... (prog-state-tape w)
#;       (prog-state-dp w)
#;       (prog-state-tape-len w)
#;       (prog-state-output w)
#;       (prog-state-program w)
#;       (prog-state-ip w)))

; string->program: String -> Program
; Given a string, returns a bf program without any invalid character
(define (string->program s)
  (local [; valid-char: Char -> Boolean
          ; Given a valid-char, returns #t if the character is a valid bf
          ; instruction.
          (define (valid-char? s)
            (ormap (lambda (x) (char=? s x))
                   '(#\> #\< #\+ #\- #\, #\. #\[ #\])))]
         (list->string (filter valid-char? (string->list s)))))

; Tests for string->program
(check-expect (string->program "hello") "")
(check-expect (string->program "+ProgState50-[]") "+-[]")
(check-expect (string->program "") "")

; add1-byte: Byte -> Byte
; Given a byte, returns the byte+1 simulating overflows
(define (add1-byte b)
  (modulo (add1 b) 256))

; Tests for add1-byte
(check-expect (add1-byte 255) 0)
(check-expect (add1-byte 254) 255)

; sub1-byte: Byte -> Byte
; Given a byte, returns the byte-1 simulating underflows
(define (sub1-byte b)
  (cond [(zero? b) 255]
        [else (sub1 b)]))

; Tests for sub1-byte
(check-expect (sub1-byte 0) 255)
(check-expect (sub1-byte 1) 0)

; program->prog-state: Program -> ProgState
; Given a program, returns the corresponding initial ProgState state.
(define (program->prog-state p)
  (prog-state (cons 0 '()) 0 1 "" p 0))

; Tests for program->prog-state
(check-expect (program->prog-state "[->+<]") (prog-state (list 0) 0 1 "" "[->+<]" 0))

; tape-help: Tape DP (Byte -> Byte) -> Tape
; Given a tape and a data pointer, returns the same tape with the data in the
; location of the data pointer altered by the function `alter`.
(define (tape-help tape dp alter)
  (cond [(zero? dp) (cons (alter (first tape)) (rest tape))]
        [else (cons (first tape) (tape-help (rest tape) (sub1 dp) alter))]))

; Tests for tape-help
(check-expect (tape-help (list 0) 0 add1-byte) (list 1))
(check-expect (tape-help (list 0 1 2 3) 2 sub1-byte) (list 0 1 1 3))

; exec-add1: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the + instruction executed
(define (exec-add1 w)
  (prog-state (tape-help (prog-state-tape w) (prog-state-dp w) add1-byte)
              (prog-state-dp w)
              (prog-state-tape-len w)
              (prog-state-output w)
              (prog-state-program w)
              (add1 (prog-state-ip w))))

; Tests for exec-add1
(check-expect (exec-add1 (prog-state
                          (list 1 2 3 4 5 6 7) 3 7 "" "+" 0))
              (prog-state (list 1 2 3 5 5 6 7) 3 7 "" "+" 1))
(check-expect (exec-add1 (prog-state
                          (list 255 1 2 3) 0 4 "" "+" 0))
              (prog-state (list 0 1 2 3) 0 4 "" "+" 1))

; exec-sub1: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the - instruction executed
(define (exec-sub1 w)
  (prog-state (tape-help (prog-state-tape w) (prog-state-dp w) sub1-byte)
              (prog-state-dp w)
              (prog-state-tape-len w)
              (prog-state-output w)
              (prog-state-program w)
              (add1 (prog-state-ip w))))

; Tests for exec-sub1
(check-expect (exec-sub1 (prog-state
                          (list 1 2 3 4 5 6 7) 3 7 "" "-" 0))
              (prog-state (list 1 2 3 3 5 6 7) 3 7 "" "-" 1))
(check-expect (exec-sub1 (prog-state
                          (list 0 1 2 3) 0 4 "" "-" 0))
              (prog-state (list 255 1 2 3) 0 4 "" "-" 1))

; exec-tape-left: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the < instruction executed
(define (exec-tape-left w)
  (if (zero? (prog-state-dp w))
      (error "Can't access negative tape positions")
      (prog-state (prog-state-tape w)
                  (sub1 (prog-state-dp w))
                  (prog-state-tape-len w)
                  (prog-state-output w)
                  (prog-state-program w)
                  (add1 (prog-state-ip w)))))

; Tests for exec-tape-left
(check-error (exec-tape-left (prog-state (list 1 2 3) 0 3 "" "<" 0)))
(check-expect (exec-tape-left (prog-state (list 1 2 3) 2 3 "" "<" 0))
              (prog-state (list 1 2 3) 1 3 "" "<" 1))
     
; exec-tape-right: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the > instruction executed
(define (exec-tape-right w)
  (local [(define end-of-tape (= (prog-state-dp w) (sub1 (prog-state-tape-len w))))]
    (prog-state
     (if end-of-tape
         (append (prog-state-tape w) (list 0))
         (prog-state-tape w)) 
     (add1 (prog-state-dp w))
     (if end-of-tape
         (add1 (prog-state-tape-len w))
         (prog-state-tape-len w))
     (prog-state-output w)
     (prog-state-program w)
     (add1 (prog-state-ip w)))))

; Tests for exec-tape-right
(check-expect (exec-tape-right (prog-state (list 1 2 3) 0 3 "" ">" 0))
              (prog-state (list 1 2 3) 1 3 "" ">" 1))
(check-expect (exec-tape-right (prog-state (list 0 1 2) 2 3 "" ">" 0))
              (prog-state (list 0 1 2 0) 3 4 "" ">" 1))

; exec-out: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the . instruction executed
(define (exec-out w)
  (prog-state
   (prog-state-tape w)
   (prog-state-dp w)
   (prog-state-tape-len w)
   (string-append
    (prog-state-output w)
    (list->string
     (list (integer->char (list-ref (prog-state-tape w) (prog-state-dp w))))))
   (prog-state-program w)
   (add1 (prog-state-ip w))))

; Tests for exec-out
(check-expect (exec-out (prog-state (list 50) 0 1 "" ".[->+<]" 0))
              (prog-state (list 50) 0 1 "2" ".[->+<]" 1))
(check-expect (exec-out (prog-state (list 65) 0 1 "" ".[->+<]" 0))
              (prog-state (list 65) 0 1 "A" ".[->+<]" 1))

; char-at: String Nat -> 1String
; Given a string and an index, returns the 1String at the position pointed by
; index
(define (char-at s i)
  (substring s i (add1 i)))

; Tests for char-at
(check-expect (char-at "malusa" 2) "l")
(check-error (char-at "another string" 300))

; WalkingDirection can be one of:
; - 'forward
; - 'backward
; Interpretation: the direction to walk the Brainf*ck Program with.

; find-matching: Program Nat WalkingDirection -> Nat
; Given a program, a starting position in the progam and a walking direction
; returns the position of the matching bracket waking in the direction provided.
(define (find-matching prg start wd)

  (define brkt (if (symbol=? wd 'forward) #\] #\[))
  (define oppos-brkt (if (symbol=? wd 'forward) #\[ #\]))
  (define upd-start (if (symbol=? wd 'forward) add1 sub1))
  
  ; fm-helper Nat Nat -> Nat
  ; Given a starting position and a nest accumulator, returns the position of
  ; the matching bracket waking in the direction provided by updating the
  ; accumulator recursively with the current level of nesting.
  (define (fm-helper s nest)
    (cond
      [(and (zero? nest) (char=? (string-ref prg s) brkt))
       s]
      [(char=? (string-ref prg s) oppos-brkt)
       (fm-helper (upd-start s) (add1 nest))]
      [(char=? (string-ref prg s) brkt)
       (fm-helper (upd-start s) (sub1 nest))]
      [else
       (fm-helper (upd-start s) nest)]))

  (fm-helper (upd-start start) 0))

; Tests for find-first
(check-expect (find-matching "[++++++---->><-]++++]+--" 0 'forward)
              15)
(check-expect (find-matching "[+++++][+---->><-]++++]+--" 7 'forward)
              17)
(check-expect (find-matching "[+++++[]+---->><-]++++]+--" 17 'backward)
              0)

; exec-loop-start: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the [ instruction executed
(define (exec-loop-start w)
  (local [(define jump (zero? (list-ref (prog-state-tape w) (prog-state-dp w))))]
    (prog-state
     (prog-state-tape w)
     (prog-state-dp w)
     (prog-state-tape-len w)
     (prog-state-output w)
     (prog-state-program w)
     (add1 (if jump
         (find-matching (prog-state-program w) (prog-state-ip w) 'forward) 
         (prog-state-ip w))))))

; Tests for exec-loop-start
(check-expect (exec-loop-start
               (prog-state '(0) 0 1 "" "[++--]++--+-[]" 0))
              (prog-state '(0) 0 1 "" "[++--]++--+-[]" 6))
(check-expect (exec-loop-start
               (prog-state '(1) 0 1 "" "[++--]++--+-[]" 0))
              (prog-state '(1) 0 1 "" "[++--]++--+-[]" 1))

; exec-loop-end: ProgState -> ProgState
; Given a ProgState, returns a new ProgState with the ] instruction executed
(define (exec-loop-end w)
  (local [(define jump (not (zero? (list-ref (prog-state-tape w) (prog-state-dp w)))))]
    (prog-state
     (prog-state-tape w)
     (prog-state-dp w)
     (prog-state-tape-len w)
     (prog-state-output w)
     (prog-state-program w)
     (add1 (if jump
         (find-matching (prog-state-program w) (prog-state-ip w) 'backward) 
         (prog-state-ip w))))))

; Tests for exec-loop-end
(check-expect (exec-loop-end
               (prog-state '(0) 0 1 "" "[++--]++--+-[]" 5))
              (prog-state '(0) 0 1 "" "[++--]++--+-[]" 6))
(check-expect (exec-loop-end
               (prog-state '(1) 0 1 "" "[++--]++--+-[]" 5))
              (prog-state '(1) 0 1 "" "[++--]++--+-[]" 1))

; execute: ProgState -> ProgState
; Given an initial ProgState state, returns the final ProgState state executing the
; program.
(define (execute w)
  (local [(define program-len (string-length (prog-state-program w)))]
    (cond [(>= (prog-state-ip w) program-len) w]
          [else
           (local [(define inst
                     (char-at (prog-state-program w) (prog-state-ip w)))]
             (execute (cond [(string=? inst "+") (exec-add1 w)]
                            [(string=? inst "-") (exec-sub1 w)]
                            [(string=? inst "<") (exec-tape-left w)]
                            [(string=? inst ">") (exec-tape-right w)]
                            [(string=? inst "[") (exec-loop-start w)]
                            [(string=? inst "]") (exec-loop-end w)]
                            [(string=? inst ".") (exec-out w)]
                            [(string=? inst ",") #f])))])))

; Tests for execute
(check-expect (execute (prog-state (list 0) 0 3 "" "" 0))
              (prog-state (list 0) 0 3 "" "" 0))
; assert that 5+2 to ASCII = "7" (WTF)
(check-expect (execute (prog-state (list 0) 0 1 ""
                                   "++>+++++[<+>-]++++++++[<++++++>-]<." 0))
              (prog-state (list 55 0) 0 2 "7"
                          "++>+++++[<+>-]++++++++[<++++++>-]<." 35))
; Run tests
(test)