#lang racket

(require racket/match)
(module+ test
  (require rackunit))

; Zipper
(struct tape (left current right) #:transparent)

; int -> tape
(define (make-tape size)
  (tape '() 0 (make-list (sub1 size) 0)))

; tape -> tape
(define (move-left t)
  (match t
    [(tape '() _ _) (error "Cannot move left, already at the start")]
    [(tape (cons prev left) val right)
     (tape left prev (cons val right))]))

; tape -> tape
(define (move-right t)
  (match t
    [(tape _ _ '()) (error "Cannot move right, already at the end")]
    [(tape left val (cons next right))
     (tape (cons val left) next right)]))

;; Alternatives that are not limited by tape size
(define (make-tape-)
  (tape '() 0 '()))
(define (move-left- t)
  (match t
    [(tape '() val right)
     (tape '() 0 (cons val right))]
    [(tape (cons prev left) val right)
     (tape left prev (cons val right))]))
(define (move-right- t)
  (match t
    [(tape left val '())
     (tape (cons val left) 0 '())]
    [(tape left val (cons next right))
     (tape (cons val left) next right)]))

; (int -> int) -> (tape -> tape)
(define ((map-tape op) t)
  (match t
    [(tape left val right)
     (tape left (op val) right)]))

; tape -> tape
(define increase (map-tape add1))

; tape -> tape
(define decrease (map-tape sub1))

; (int, tape) -> tape
(define (replace val t) ((map-tape (const val)) t))

; tape -> (int, tape)
(define (extract t) (cons (tape-current t)
                          t))

; World with I/O
(struct world-state (input output tape) #:transparent)

; (tape -> tape) -> (world-state -> world-state)
(define ((pure-op f) w)
  (match w
    [(world-state input output t)
     (world-state input output (f t))]))

; ((i, tape) -> tape) -> (world-state -> world-state)
(define ((pure-read f) w)
  (match w
    [(world-state (cons current input) output t)
     (world-state input output (f current t))]))

; (tape -> (o, tape)) -> (world-state -> world-state)
(define ((pure-write f) w)
  (match w
    [(world-state input output t)
     (let [(result (f t))]
       (world-state input (cons (car result) output) (cdr result)))]))

; Op = < | > | + | - | @ | *
; (list (Op, (world-state -> world-state)))
(define ops
  `((< . ,(pure-op move-left))
    (> . ,(pure-op move-right))
    (+ . ,(pure-op increase))
    (- . ,(pure-op decrease))
    (@ . ,(pure-read replace))
    (* . ,(pure-write extract))))

; cmd = Op | (list Op)
; cmd, world-state -> world-state
(define (eval-cmd cmd w)
  (cond
    [(symbol? cmd)
     (let [(cmd-function (assq cmd ops))]
       (if cmd-function
           ((cdr cmd-function) w)
           (error "Unknown command:" cmd)))]
    [(list? cmd)
     (if (zero? (tape-current (world-state-tape w)))
         w
         (eval-cmd cmd (eval-prg cmd w)))]))

; ((list cmd), world-state) -> world-state
(define (eval-prg prg w)
  (foldl eval-cmd w prg))

; (int, (list cmd), (list i)) -> (list o)
(define (run-prg size prg inputs)
  (reverse (world-state-output (eval-prg prg (world-state inputs '() (make-tape size))))))

(module+ test
  (define bf-sum '(@ > @ [- < + >] < *))
  (define bf-product '(@ > @ < [- > [- > + > + < <] > [- < + >] < <] > > > *))
  (check-equal? (run-prg 10 bf-sum '(7 13)) '(20))
  (check-equal? (run-prg 10 bf-product '(10 15)) '(150)))