;----------------------------------------------------------------------------------------------

; The tape is a doubly-linked list of "cells".  Each cell is a pair in which the cdr points
; to the cell on its right, and the car is a vector containing: 0: the value of the cell;
; 1: pointer to the cell on this cell's left; 2: #t if the cell has never been written.

; Make a new cell with the given contents, but linked to no other cell(s).
; (This is the only place that a cell can be marked as un-written.)
(define make-cell
  (lambda (val . opt-unwrit)
    (list (vector val '() (if (pair? opt-unwrit) (car opt-unwrit) #f)))))

; Return the un-written flag of the cell.
(define cell-unwrit?
  (lambda (cell)
    (vector-ref (car cell) 2)))

; Return the value of the cell.
(define cell-get
  (lambda (cell)
    (vector-ref (car cell) 0)))

; Store the value of the cell.
; Clears the un-written flag of the cell.
(define cell-set!
  (lambda (cell val)
    (vector-set! (car cell) 0 val)
    (vector-set! (car cell) 2 #f)))

; Return the cell to the right of the given cell on the tape.
; Returns () if there is no cell to the right.
(define cell-right
  (lambda (cell)
    (cdr cell)))

; Return the cell to the left of the given cell on the tape.
; Returns () if there is no cell to the left.
(define cell-left
  (lambda (cell)
    (vector-ref (car cell) 1)))

; Return the cell to the right of the given cell on the tape.
; Extends the tape with the give blank symbol if there is no cell to the right.
; Optionally, passes the given un-written flag to make-cell (if needed).
(define cell-extend-right
  (lambda (cell blank . opt-unwrit)
    (if (null? (cdr cell))
      (let ((new (if (pair? opt-unwrit) (make-cell blank (car opt-unwrit)) (make-cell blank))))
        (vector-set! (car new) 1 cell)
        (set-cdr! cell new)
        new)
      (cell-right cell))))

; Return the cell to the left of the given cell on the tape.
; Extends the tape with the give blank symbol if there is no cell to the left.
; Optionally, passes the given un-written flag to make-cell (if needed).
(define cell-extend-left
  (lambda (cell blank . opt-unwrit)
    (if (null? (vector-ref (car cell) 1))
      (let ((new (if (pair? opt-unwrit) (make-cell blank (car opt-unwrit)) (make-cell blank))))
        (set-cdr! new cell)
        (vector-set! (car cell) 1 new)
        new)
      (cell-left cell))))

; Make a new tape whose cells contain the values in the given list.
; Optionally, pad the tape per the given blank symbol, left-padding and right-padding amounts.
(define make-tape
  (lambda (values . opt-pads)
    (unless (pair? values) (error 'make-tape "values argument is not a list" pads))
    (let* ((tape (make-cell (car values)))
           (last (do ((values (cdr values) (cdr values))
                      (cell tape (cell-extend-right cell (car values))))
                     ((null? values) cell))))
      (when (pair? opt-pads)
        (let ((blank (list-ref opt-pads 0))
              (left (list-ref opt-pads 1))
              (right (list-ref opt-pads 2)))
          (unless (and (integer? left) (integer? right))
            (error 'make-tape "padding arguments must be integers" opt-pads))
          (do ((count 0 (1+ count))
               (cell last (cell-extend-right cell blank #t)))
              ((>= count right)))
          (do ((count 0 (1+ count))
               (cell tape (cell-extend-left cell blank #t)))
              ((>= count left)))))
      tape)))

; Make a deep copy of the given tape.
; Note:  Only copies from the given cell forward.
(define tape-copy
  (lambda (tape)
    (let ((copy (make-cell (cell-get tape))))
      (do ((tape (cdr tape) (cdr tape))
           (cell copy (cell-extend-right cell (cell-get tape))))
          ((null? tape)))
      copy)))

; Return the first cell on a tape.
; Optionally, leading blank symbols are not included (will return last cell of blank tape).
(define tape-fst
  (lambda (cell . opt-blank)
    (let ((fst (do ((fst cell (cell-left fst))) ((null? (cell-left fst)) fst))))
      (if (null? opt-blank)
        fst
        (do ((fst fst (cell-right fst)))
            ((or (null? (cell-right fst)) (not (eq? (car opt-blank) (cell-get fst)))) fst))))))

; Return the last cell on a tape.
; Optionally, trailing blank symbols are not included (will return first cell of blank tape).
(define tape-lst
  (lambda (cell . opt-blank)
    (let ((lst (do ((lst cell (cell-right lst))) ((null? (cell-right lst)) lst))))
      (if (null? opt-blank)
        lst
        (do ((lst lst (cell-left lst)))
            ((or (null? (cell-left lst)) (not (eq? (car opt-blank) (cell-get lst)))) lst))))))

; Return true if the given tape is empty.  (I.e. contains nothing but blank symbols.)
(define tape-empty?
  (lambda (cell blank)
    (let ((fst (tape-fst cell blank)))
      (and (null? (cell-right fst)) (eq? blank (cell-get fst))))))

; Convert the contents of a tape to a string.
; Place a mark around the indicated cell (if any match).
; Prints the entire contents regardless of which cell is given.
; Optionally, leading and trailing instances of the given blank symbol are suppressed.
; The values of un-written cells are not shown, though space for them is included.
(define tape->string
  (lambda (cell mark . opt-blank)
    (let ((strlst (list #\[))
          (marked-prev #f)
          (fst (if (null? opt-blank) (tape-fst cell) (tape-fst cell (car opt-blank))))
          (lst (if (null? opt-blank) (tape-lst cell) (tape-lst cell (car opt-blank)))))
      (do ((cell fst (cell-right cell)))
          ((eq? cell (cell-right lst)))
        (let* ((mark-now (eq? cell mark))
               (fmtstr (cond (mark-now " {~a}") (marked-prev " ~a") (else "  ~a")))
               (value (if (and (not mark-now) (cell-unwrit? cell)) " " (cell-get cell))))
          (set! strlst (append strlst (string->list (format fmtstr value))))
          (set! marked-prev mark-now)))
      (list->string (append strlst (string->list (if marked-prev " ]" "  ]")))))))

;----------------------------------------------------------------------------------------------

; A Turing Machine contains the 7-tuple that formally defines it, stored in an array to
; make access relatively fast.  The transitions are stored in an association list keyed by
; the pair (q_i . s_j) for ease of lookup.

; Make a new Turing Machine from the given arguments:
; Symbols list, blank symbol, input symbols list, states list, initial state, final (accepting)
; states list, and list of transitions.  A transition is a 5-element list of: state (q_i),
; symbol read (s_i), symbol to write (s_ij), direction to move (d_ij), and next state (q_ij).
(define make-turing
  (lambda (symbols blank inputs states initial finals . transitions)
    ; Raise error if any element in list lst is not in list set.
    (define all-list-in-set
      (lambda (set lst msg)
        (for-each (lambda (val) (unless (memq val set) (error 'make-turing msg val))) lst)))
    ; Raise error if the given transition is not correctly formed.
    (define transition-validate
      (lambda (tran)
        (when (or (not (list? tran)) (not (= 5 (length tran))))
              (error 'make-turing "transition not a length-5 list" tran))
        (let ((q_i (list-ref tran 0))
              (s_j (list-ref tran 1))
              (s_ij (list-ref tran 2))
              (d_ij (list-ref tran 3))
              (q_ij (list-ref tran 4)))
          (unless (memq q_i states) (error 'make-turing "q_i not in states" q_i))
          (unless (memq s_j symbols) (error 'make-turing "s_j not in symbols" s_j))
          (unless (memq s_ij symbols) (error 'make-turing "s_ij not in symbols" s_ij))
          (unless (memq d_ij '(L R N)) (error 'make-turing "d_ij not in {L R N}" d_ij))
          (unless (memq q_ij states) (error 'make-turing "q_ij not in states" q_ij)))))
    ; Convert the given transitions list into an alist of transitions keyed by (q_i . s_j).
    (define transitions-alist
      (lambda (trns)
        (cond ((null? trns) '())
              (else (cons (cons (cons (caar trns) (cadar trns)) (list (cddar trns)))
                          (transitions-alist (cdr trns)))))))
    ; Validate all the arguments.
    (unless (list? symbols) (error 'make-turing "symbols not a list" symbols))
    (unless (memq blank symbols) (error 'make-turing "blank not in symbols" blank))
    (all-list-in-set symbols inputs "inputs not all in symbols")
    (unless (list? states) (error 'make-turing "states not a list" states))
    (unless (memq initial states) (error 'make-turing "initial not in states" initial))
    (all-list-in-set states finals "finals not all in states")
    (for-each (lambda (tran) (transition-validate tran)) transitions)
    ; Construct and return the Turing Machine tuple vector.
    (let ((tuple (make-vector 7)))
      (vector-set! tuple 0 symbols)
      (vector-set! tuple 1 blank)
      (vector-set! tuple 2 inputs)
      (vector-set! tuple 3 states)
      (vector-set! tuple 4 initial)
      (vector-set! tuple 5 finals)
      (vector-set! tuple 6 (transitions-alist transitions))
      tuple)))

; Return the symbols of a Turing Machine.
(define-syntax turing-symbols (syntax-rules () ((_ tm) (vector-ref tm 0))))

; Return the blank symbol of a Turing Machine.
(define-syntax turing-blank (syntax-rules () ((_ tm) (vector-ref tm 1))))

; Return the input symbols of a Turing Machine.
(define-syntax turing-inputs (syntax-rules () ((_ tm) (vector-ref tm 2))))

; Return the states of a Turing Machine.
(define-syntax turing-states (syntax-rules () ((_ tm) (vector-ref tm 3))))

; Return the initial state of a Turing Machine.
(define-syntax turing-initial (syntax-rules () ((_ tm) (vector-ref tm 4))))

; Return the final states of a Turing Machine.
(define-syntax turing-finals (syntax-rules () ((_ tm) (vector-ref tm 5))))

; Return the transitions of a Turing Machine.
(define-syntax turing-transitions (syntax-rules () ((_ tm) (vector-ref tm 6))))

; Return the q_i (current state) of alist element transition.
(define-syntax tran-q_i (syntax-rules () ((_ atran) (car (car atran)))))

; Return the s_j (symbol read from the tape) of alist element transition.
(define-syntax tran-s_j (syntax-rules () ((_ atran) (cdr (car atran)))))

; Return the s_ij (symbol written) of alist element transition.
(define-syntax tran-s_ij (syntax-rules () ((_ atran) (car (cadr atran)))))

; Return the d_ij (direction of move) of alist element transition.
(define-syntax tran-d_ij (syntax-rules () ((_ atran) (cadr (cadr atran)))))

; Return the q_ij (state transition) of alist element transition.
(define-syntax tran-q_ij (syntax-rules () ((_ atran) (caddr (cadr atran)))))

; Lookup the transition matching the given state and symbol in the given Turing Machine.
(define atrns-lookup
  (lambda (state symbol tm)
    (assoc (cons state symbol) (turing-transitions tm))))

; Convert the given Turing Machine transition to a string.
(define tran->string
  (lambda (atran)
    (format "(~a ~a ~a ~a ~a)"
      (tran-q_i atran) (tran-s_j atran) (tran-s_ij atran) (tran-d_ij atran) (tran-q_ij atran))))

; Convert the given Turing Machine definition to a string.
; Options (zero or more) are, in order: component prefix string (default "");
; component suffix string (default ""); component separator string (default newline).
(define turing->string
  (lambda (tm . opts)
    (let ((prestr (if (> (length opts) 0) (list-ref opts 0) ""))
          (sufstr (if (> (length opts) 1) (list-ref opts 1) ""))
          (sepstr (if (> (length opts) 2) (list-ref opts 2) (make-string 1 #\newline)))
          (strlst '()))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-symbols tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-blank tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-inputs tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-states tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-initial tm) sufstr sepstr))))
      (set! strlst (append strlst (string->list
        (format "~a~a~a~a" prestr (turing-finals tm) sufstr
          (if (> (length (turing-transitions tm)) 0) sepstr "")))))
      (do ((index 0 (1+ index)))
          ((>= index (length (turing-transitions tm))))
        (set! strlst (append strlst (string->list
          (format "~a~a~a~a" prestr (tran->string (list-ref (turing-transitions tm) index)) sufstr
            (if (< index (1- (length (turing-transitions tm)))) sepstr ""))))))
      (list->string strlst))))

;----------------------------------------------------------------------------------------------

; Run the given Turing Machine on the given input tape.
; If specified, display log of progress.  Optionally, abort after given number of iterations.
; Returns the count of iterations, the accepting state (if one; else void), and the output
; tape as multiple values.
(define turing-run
  (lambda (tm cell show-log? . opt-abort)
    ; Validate contents of input tape.  (Leading/trailing blanks allowed; internals are not.)
    (unless (tape-empty? cell (turing-blank tm))
      (let ((fst (tape-fst cell (turing-blank tm)))
            (lst (tape-lst cell (turing-blank tm))))
        (if (eq? fst lst)
          (unless (memq (cell-get fst) (turing-symbols tm))
            (error 'turing-run "input tape has disallowed content" (cell-get fst)))
          (do ((cell fst (cell-right cell)))
              ((eq? cell (cell-right lst)))
            (unless (memq (cell-get cell) (turing-inputs tm))
                  (error 'turing-run "input tape has disallowed content" (cell-get cell)))))))
    ; Initialize state and head.
    (let ((state (turing-initial tm)) (head cell) (atran #f)
          (abort (and (pair? opt-abort) (integer? (car opt-abort))
                      (> (car opt-abort) 0) (car opt-abort))))
      ; Loop until no transition matches state/symbol or reached a final state.
      (do ((count 0 (1+ count))
           (atran (atrns-lookup state (cell-get head) tm)
                  (atrns-lookup state (cell-get head) tm)))
          ((or (not atran) (memq state (turing-finals tm)) (and abort (>= count abort)))
           ; Display final progress (optional).
           (when show-log?
             (let* ((string (format "~a" state))
                    (strlen (string-length string))
                    (padlen (max 1 (- 25 strlen)))
                    (strpad (make-string padlen #\ )))
               (printf "~a~a~a~%" string strpad (tape->string cell head))))
           ; Return resultant count, accepting state (or void), and tape.
           (values count (if (memq state (turing-finals tm)) state (void)) head))
        ; Display progress (optional).
        (when show-log?
          (let* ((string (format "~a ~a  ->  ~a ~a ~a" state (cell-get head)
                                 (tran-s_ij atran) (tran-d_ij atran) (tran-q_ij atran)))
                 (strlen (string-length string))
                 (padlen (max 1 (- 25 strlen)))
                 (strpad (make-string padlen #\ )))
            (printf "~a~a~a~%" string strpad (tape->string cell head))))
        ; Iterate.
        (cell-set! head (tran-s_ij atran))
        (set! state (tran-q_ij atran))
        (set! head (case (tran-d_ij atran)
                         ((L) (cell-extend-left head (turing-blank tm)))
                         ((R) (cell-extend-right head (turing-blank tm)))
                         ((N) head)))))))

;----------------------------------------------------------------------------------------------