; This implementation is not optimized for efficiency. It was more a vehicle
; to test some features like call-with-cc and variable-length parameter lists.

; Comments, questions, bug reports etc. to
;       Ulf Dittmer       ucdittme@top.cis.syr.edu

; use "empty" as band if you want to start with a band full of zeros

(define empty '(0))

; Format of the state table: Each line represents one state, the first
; entry for reading a 0, the second one for reading a 1.
; The first symbol in each entry is the character to be printed on the band,
; the second is the direction to go with #\l = left, #\r = right and #\s = stop.
; The third is the new state into which to switch.

; This scheme can be extended to cover more symbols than just 0 and 1.
; Just add more entries to each line in the state table. It must be
; a proper Scheme vector with as many elements as there are states.

; busiest beaver (= prints the most "1"s) with 3 states

(define table1 '#(((1 #\r 2) (1 #\l 3))
                ((1 #\l 1) (1 #\r 2))
                ((1 #\l 2) (1 #\s))))

; produces 511 "1"s

(define table2 '#(((1 #\r 2) (0 #\l 3))
                 ((1 #\r 3) (1 #\r 4))
                 ((1 #\l 1) (0 #\r 2))
                 ((0 #\r 5) (1 #\s))
                 ((1 #\l 3) (1 #\r 1))))

; produces 1915 "1"s

(define table3 '#(((1 #\r 2) (1 #\l 3))
                 ((0 #\l 1) (0 #\l 4))
                 ((1 #\l 1) (1 #\s))
                 ((1 #\l 2) (1 #\r 5))
                 ((0 #\r 4) (0 #\r 2))))

; copy machine
; Appends the leftmost string of "1"s to the next string of "1"s on the right side.
; e.g. (turing table4 '(1 1 1 0)) ==> (1 1 1 0 1 1 1)

(define table4 '#(((0 #\r 1) (0 #\r 2))
                 ((0 #\r 3) (1 #\r 2))
                 ((1 #\l 4) (1 #\r 3))
                 ((0 #\l 5) (1 #\l 4))
                 ((1 #\l 8) (1 #\l 6))
                 ((1 #\r 7) (1 #\l 6))
                 (('does 'not 'occur) (0 #\r 2))
                 ((0 #\s) (1 #\l 8))))

; multiplication machine (includes copy machine in states 7 through 14)
; Multiplies the leftmost strings of "1"s and appends the result
; to the next string of "1"s to the right of the factors.
; e.g. (turing table5 '(1 1 0 1 1 1)) ==> (1 1 0 1 1 1 0 1 1 1 1 1 1)

(define table5 '#(((0 #\r 1) (0 #\r 2))
                 ((0 #\r 7) (1 #\r 2))
                 ((1 #\l 6) (1 #\l 4))
                 ((1 #\r 5) (1 #\l 4))
                 (('does 'not 'occur) (0 #\r 2))
                 ((0 #\s) (1 #\l 6))
                 ((0 #\r 7) (0 #\r 8))
                 ((0 #\r 9) (1 #\r 8))
                 ((1 #\l 10) (1 #\r 9))
                 ((0 #\l 11) (1 #\l 10))
                 ((1 #\l 14) (1 #\l 12))
                 ((1 #\r 13) (1 #\l 12))
                 (('does 'not 'occur) (0 #\r 8))
                 ((0 #\l 3) (1 #\l 14))))

; parameters : state_table band [start_position [print]]]
; default values :
; band : empty (all zeros)
; start_position  : 0 (which means the leftmost position)
; print : 0 (only the final band configuration is printed, not the intermediate steps)

(define (turing table . args)
  (let ((band (if (= (length args) 0)
                  empty
                  (car args)))
        (print #f))
    (define (turing-help zustand pos)
      (call-with-current-continuation
       (lambda (ende)
         (let* ((input (list-ref band pos))
                (command (list-ref (vector-ref table (- zustand 1)) input))
                (output (car command)))
           (cond ((= pos 0) (set! band (cons output (cdr band)))) 
                 ((= pos (- (length band) 1)) (set! band (append
                                                          (list-head band pos)
                                                          (list output))))
                 (else (set! band (append
                                   (list-head band pos)
                                   (list output)
                                   (list-tail band (+ pos 1))))))
; the following line ensures that the band is only printed if a value has changed
           (if (and print (not (= input output)))
               (begin (display band) (newline)))
           (cond ((char=? (cadr command) #\r)
                  (if (< (+ pos 1) (length band))
                      (set! pos (+ pos 1))
                      (begin (set! band (append band (list 0)))
                             (set! pos (+ pos 1)))))
                 ((char=? (cadr command) #\l)
                  (if (= pos 0)
                      (set! band (append (list 0) band))
                      (set! pos (- pos 1))))
                 (else (ende (if print 'done band))))
           (turing-help (caddr command) pos)))))
    (if (< (length args) 2)
        (turing-help 1 0)
        (let ((start (cadr args)))
          (if (< start (length band))
              (if (equal? (cddr args) '())
                  (turing-help 1 start)
                  (if (= (caddr args) 1)
                     (begin (set! print #t) (turing-help 1 start))
                      (turing-help 1 start)))
              (display "Error : start position is greater than band length"))))))

(define (list-head lis n)
  (reverse (list-tail (reverse lis) (- (length lis) n))))