; Turing machine simulator using Scheme
; by Robert Keller

(load "tester.scm")

; The value of trace, if #t, will cause the machine state to be shown at each step.

(define trace #f)

; Turing machine representation:
; A TM is represented as a list of 5-tuples, where each 5-tuple is:
;
; (current-state current-symbol-read symbol-written motion next-state)
;
; By convention, the curent-state of the first 5-tuple is the initial state.
;
; Names of states and symbols is arbitrary, except that we have a
; fixed convention for the blank symbol, using the symbol defined next:

(define blank '_)


; Symbols for head motion are defined here;

(define left  'L) ; meaning the tape head moves to the left
(define right 'R) ; meaning the tape head moves to the right
(define none  'N) ; meaning the tape head does not move


; In a deterministic TM there is at most one next-state, symbol-written, and head motion
; for a given current-state current-symbol-read. However, there also might be none.
; In this case, a combination for which there is no next-state, etc. is considered  
; to be a halting state.

; Our version of a TM has a two-way unbounded tape.
; Initially the head is assumed to be positioned at the left end of the input.
; The argument to tmsim is a list representing this portion of the tape.
; At the end, the result is assumed to be whatever is on the tape. 
; The result of tmsim is a list of 3 elements: 
;    The part of the tape to the left of the head, with leading blanks removed.
;    The control state when the machine stops.
;    The part of the tape to the right of the head, with trailing blanks removed.

(define (tmsim machine initial-tape)
  (tmsim-helper machine (first (first machine)) '() initial-tape))


; Function tmsim-helper simulates the behavior of a machine from its
; current state and tape to the completion of the computation, if there
; is a completion.
;
; Note that left-tape is the tape from the left of the head leftward,
; so it reads in the opposite direction from right-tape.
; This is a matter of convenience in manipulating the tape.

(define (tmsim-helper machine current-state left-tape right-tape)
  (begin
    (if trace
        (begin
          (display (reverse left-tape))
          (display " ")
          (display current-state)
          (display " ")
          (display right-tape)
          (newline)))
    
    ; find the tuple representing the current state and symbol read.
    
    (let ((found-tuple (find-tuple current-state (first-symbol right-tape) machine)))
      
      (if (null? found-tuple)
          
          ; If no tuple is found, we have the halting condition, no next state.
          (final current-state left-tape right-tape)
          
          ; If a tuple is found, then the simulation continues with a new state.
          (let (
                (symbol-written (third found-tuple))
                (motion         (fourth found-tuple))
                (next-state     (fifth found-tuple))
                )
            
            (cond ; Determine one of three possible motions: left, right, none.
              
              ((equal? motion right) 
               (tmsim-helper
                machine
                next-state
                (cons symbol-written left-tape)
                (if (null? right-tape) (list blank) (rest right-tape))))
              
              ; Above, as the right part of the tape includes the symbol being read, we have to
              ; introduce a new blank in case we are moving right into new territory.
              
              ((equal? motion left)
               (tmsim-helper
                machine
                next-state
                (rest-tape left-tape)
                (cons (first-symbol left-tape) (cons symbol-written (rest-tape right-tape)))))
              
              ((equal? motion none)
               (tmsim-helper
                machine
                next-state
                left-tape
                (cons symbol-written (rest-tape right-tape))))
              
              (else (error "erroneous tuple" found-tuple))
              ))))))


; find-tuple returns the first 5-tuple in tuples matching the state and symbol.
; If there is no such match, () is returned.

(define (find-tuple state symbol tuples)
  (if (null? tuples)
      ()
      (let ((first-tuple (first tuples)))
        (if (and
             (equal? state  (first first-tuple))
             (equal? symbol (second first-tuple)))
            
            first-tuple                                   ; found
            
            (find-tuple state symbol (rest tuples))))))   ; continue looking


; first-symbol takes into account that we may be at the end of the tape,
; in which case the first-symbol is taken to be a blank.

(define (first-symbol tape)
  (if (null? tape)
      blank
      (first tape)))


; rest-tape takes into account that we may be at the end of the tape,
; in which case the rest is also empty.

(define (rest-tape tape)
  (if (null? tape)
      ()
      (rest tape)))


; Function final packages the final state as a 3-element list,
; the left part of the tape in proper orientation (rather than reversed
; as is used in the simulation), the final state, and the right part of
; the tape.

(define (final current-state left-tape right-tape)
  (list (drop-leading-blanks (reverse left-tape))
        current-state 
        (drop-trailing-blanks right-tape)))


; drop-trailing-blanks removes any trailing blanks from its argument

(define (drop-trailing-blanks tape)
  (reverse (drop-leading-blanks (reverse tape))))

; drop-leading-blanks removes any trailing blanks from its argument

(define (drop-leading-blanks tape)
  (if (null? tape)
      ()
      (if (equal? blank (first tape))
          (drop-leading-blanks (rest tape))
          tape)))


; add1-1adic is a TM that adds 1 to the 1-adic representation of a number.
; In this representation, the number n is represented by a list of n 1's.
; Number 0 is represented by the empty list.

(define add1-1adic
  '(
    (start   _ 1 N stop)
    (start   1 1 L deposit)
    (deposit _ 1 N stop)
    ))

(test (tmsim add1-1adic '(1 1 1))          '(() stop (1 1 1 1)))
(test (tmsim add1-1adic '(1 1 1 1 1 1 1))  '(() stop (1 1 1 1 1 1 1 1)))
(test (tmsim add1-1adic '(1))              '(() stop (1 1)))
(test (tmsim add1-1adic '())               '(() stop (1)))


; add1-binary is a TM that adds 1 to the binary representation of a number,
; most-significant bit first.
;
; With the head positioned at the left end of the tape, it moves to the
; right end, staying in state 'start. 
; The right end is sensed by encountering a blank, taking the machine to state 'adding.
; The head then moves left to the rightmost 0, or blank if there is no 0, all the while
; in state 'adding. As it moves, 1's are replaced with 0's.
; When the rightmost 0 is encountered, it is replaced with a 1 and 'finishing is entered.
; If there is no 0, then _ will be reached, and it will be replaced with a 1, then the
; machine stops.
; In state 'finishing, the machine moves to the left toward the end, and stops when a _
; is encountered.

(define add1-binary 
  '(
    (start           0 0 R start)       ; Move right to _, leaving other symbols as is.
    (start           1 1 R start)
    (start           _ _ L adding)      ; First _ to the right encountered, start moving left.
    
    (adding          _ 1 N stop)        ; Move left to 0 or _, replacing 1's with 0's.
    (adding          0 1 L finishing)   ; Upon encountering a 0 or _, a 1 is written,
    (adding          1 0 L adding)      ; then the computation finishes up.
    
    (finishing       0 0 L finishing)   ; Move left to _, leaving symbols as is, then stop.
    (finishing       1 1 L finishing)
    (finishing       _ _ R stop)        
    ))

(test (tmsim add1-binary   '(1 0 0 1))  '(() stop (1 0 1 0)))
(test (tmsim add1-binary '(1 0 0 1 1))  '(() stop (1 0 1 0 0)))
(test (tmsim add1-binary   '(1 1 1 1))  '(() stop (1 0 0 0 0)))
(test (tmsim add1-binary         '(0))  '(() stop (1)))
(test (tmsim add1-binary         '(1))  '(() stop (1 0)))
(test (tmsim add1-binary '(0 0 0 0 0))  '(() stop (0 0 0 0 1)))


; Below is an example of a Busy-Beaver machine. 
; The objective is, with a given number of states, and only two tape symbols, 1 and _ say,
; write as many 1's as possible, then halt. 
; The winner of the Busy-Beaver(n) competition is the n-state machine that writes the most 1's.

; busy4 happens to be the winner of Busy-Beaver(4).

(define busy4 
  '(
    (A _ 1 R B)
    (A 1 1 L B)
    (B _ 1 L A)
    (B 1 _ L D)
    (C _ 1 R C)
    (C 1 _ R A)
    (D _ 1 R stop)
    (D 1 1 L C)
    ))

(test (tmsim busy4 ()) '((1) stop (_ 1 1 1 1 1 1 1 1 1 1 1 1)))


; This Busy-Beaver(5) contestant stops with 4098 1's on its tape. 
; The winner of Busy-Beaver(5) is not yet known. 

(define busy5
  '(
    (1 _ 1 R 2)
    (1 1 1 R 1)
    (2 _ 1 L 3)
    (2 1 1 L 2)
    (3 _ 1 R 1)
    (3 1 1 L 4)
    (4 _ 1 R 1)
    (4 1 1 L 5)
    (5 _ 1 L 0)
    (5 1 _ L 3)))

(define (count-1s-on-tape triple)
  (+
   (length (filter (lambda (x) (equal? x 1)) (first triple)))
   (length (filter (lambda (x) (equal? x 1)) (third triple)))))

; (test (count-1s-on-tape (tmsim busy5 ())) 4098) ; This test takes awhile.


; The function that gives the number of 1's printed by an n-state busy-beaver
; machine is not computable, but specific cases might be proved a winner.
; For a 6-state machine, there is a machine that prints about 4.64e101439 1's.

(tester 'show)