;                 /----------------------------------------\
;                 |    T U R I N G  -  M A S C H I N E     |
;                 |    Januar 1990 von Frank W. Hinkel     |
;                 \----------------------------------------/


; **************************************************************************
; *******************  Definition der Turing-Maschine  *********************
; **************************************************************************

(define (turing tape table)
  ;;; Die Turingmaschine wird mit einem Band und einer Tafel aufgerufen.
  ;;; Es handelt sich also um eine universelle Turingmaschine


  ;;; Startzustand
  (define q (first table))

  ;;; Endzustand
  (define HALT (second table))

  ;;; Start- Endzustand abschneiden
  (set! table (cddr table))

  ;;; Z„hler
  (define count 0)
  
  (define (t-aux)
    (set! count (1+ count))
    (define s (second (assoc q table))) ; hole A-Liste fr alten Zustand q
    (define h (tape 'read))          ; lese Bandkopf nach h
    (define c (assoc h s))           ; hole Quadrupel fr aktuellen Bandkopf

    (invariant (not (null? c))       ; Fehler, kein Quadrupel fr Bandpos.
               "unexpected tapeconfiguration '" (tape 'tape)
               "' in State " q)
    
    (debug 1 (tape 'tape))           ; Debugging Information
    (debug 2 "State: " q " Head: " h " --> {" 
              (first c) " " (second c) " " (third c) " " (fourth c) "}")

    ((tape 'write) (third c))        ; schreibe neues Datum auf Band
    (tape (fourth c))                ; bewege Band ( L,R oder N )
    (set! q (second c))              ; neuer Zustand nach q
    (if (= HALT q)                   ; neuer Zustand gleich qH, dann HALT
        (tape 'tape)                 ; sonst weiter
        (t-aux)))

  ;;; Body von "turing" 
  (define oldtape (tape 'tape))
  (define result (t-aux))
  (debug "Function: " oldtape " =" count "=> " result)
  result)


; *************************************************************************
; *****  Definition des Bandes ( rechts- und linksseitig unendlich )  *****
; *************************************************************************

(define (make-tape r-tape)
  ;;; Der Parameter r-tape initialisiert die rechte Bandseite.

  ;;; Lokale Variablen
  (define l-tape "")   ;;; linke Bandseite
  (define h-tape "B")  ;;; Bandinhalt an Kopfposition

  ;;; Schreiben auf Band
  (define (write m)
    (set! h-tape m)
    (display))

  ;;; Bewege Schreib/Lese-kopf Links
  (define (left)
    (set! r-tape (rtrimstring (concatstring h-tape r-tape) "B"))
    (set! h-tape (rightstring  (concatstring "B" l-tape))) 
    (set! l-tape (leftstring l-tape (max 0 (- (lenstring l-tape) 1))))
    (display))

  ;;; Bewege Schreib/Lese-kopf nach Rechts
  (define (right)
    (set! l-tape (ltrimstring (concatstring l-tape h-tape) "B"))
    (set! h-tape (leftstring  (concatstring r-tape "B")))
    (set! r-tape (midstring r-tape 2))
    (display))

  ;;; Gesamtes Band als String ausgeben
  (define (display)
    (concatstring "[..B" l-tape ">" h-tape "<" r-tape "B..]"))


  ;;; Message-Dispatcher (wird von "make-tape" zurckgegeben)
  (define (dispatch m)
    (cond ((= 'read m)  h-tape)
          ((= 'write m) write)
          ((= 'L m)     (left))
          ((= 'R m)     (right))
          ((= 'N m)     (display))
          ((= 'tape m)  (display))
          (else         (error "Bad Message in Tape-Dispatcher :" m))))

  ;;; Body von make-tape
  dispatch) ; Wert von "make-tape" ist die Prozedur dispatch

; ==========================================================================
; ==========================================================================

; **************************************************************************
; *************************  Tabellenstatistik  ****************************
; **************************************************************************

;;; Gibt eine Turing-Tafel formatiert aus

(define (statistic table)
  (define (print-states table)
    (cond ((null? table) nil)
          (else (newline)
                (princ "  State ")
                (define q (caar table))
                (print q)
                (print-quads q (cadar table))
                (print-states (cdr table)))))
  (define (print-quads q quads)
    (cond ((null? quads) nil)
          (else (princ "    ")
                (print (cons q (first quads)))
                (print-quads q (cdr quads)))))

  (newline)
  (princ "Turing-Table with ")
  (princ (length (cddr table)))
  (print " states :")
  (princ "  Startstate ")
  (princ (first table))
  (princ " Endstate ")
  (print (second table))
  (print-states (cddr table)))

; **************************************************************************
; ********************  Definition der Status-Tabellen  ********************
; **************************************************************************

;;; Addiere 1 zur Eingabe ( Bin„r ).

(define add-1
  '(q0 qH
    (q0 (("B" q1 "B" R)))
    (q1 (("0" q1 "0" R)
         ("1" q1 "1" R)
         ("B" q2 "B" L)))
    (q2 (("0" q3 "1" N)
         ("1" q4 "0" N)
         ("B" q3 "1" N)))
    (q3 (("0" q3 "0" L)
         ("1" q3 "1" L)
         ("B" qH "B" N)))
    (q4 (("0" q2 "0" L)
         ("1" q2 "1" L)))))

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

;;; Verschiebe String aus Alphabet {1,2} zwei Zeichen nach rechts und be-
;;; schreibe die freigewordenen Positionen mit zwei Y's. Bleibe auf dem
;;; zweiten Y stehen.
;;;
;;; Beispiel "[..B>B<121B..]" wird zu "[..BY>Y<121B..]"

(define shift-2-right
  '(q0 qH
    (q0 (("B" q1 "Y" R)))
    (q1 (("B" q2 "B" L)
         ("1" q1 "1" R)
         ("2" q1 "2" R)))
         
    ; verschiebe zwei nach rechts und l”sche alte Position
    (q2 (("Y" q3 "B" R)
         ("1" q5 "B" R)
         ("2" q7 "B" R)))
         
    ; schreibe "YY"
    (q3 (("B" q9 "Y" R)))
    (q9 (("B" qH "Y" N)))
         
    ; berspringe linke b's
    (q4 (("B" q4 "B" L)
         ("Y" q3 "B" R)
         ("1" q2 "1" N)
         ("2" q2 "2" N)))
         
    ; verschiebe "1"
    (q5 (("B" q6 "B" R)))
    (q6 (("B" q4 "1" L)))
    
    ; verschiebe "2"
    (q7 (("B" q8 "B" R)))
    (q8 (("B" q4 "2" L)))))

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

(define busy-beaver-3 ; h„lt nach 11 Schritten, mit 6 Strichen
  '(1 H
    (1 (("B" 2 "|" R)
        ("|" 3 "|" L)))
    (2 (("B" 3 "|" R)
        ("|" H "|" N)))
    (3 (("B" 1 "|" L)
        ("|" 2 "B" L)))))

(define busy-beaver-4 ; h„lt nach 96 Schritten, mit 13 Strichen.
  '(1 H
    (1 (("B" 2 "|" R)
        ("|" 3 "B" R)))
    (2 (("B" 1 "|" L)
        ("|" 1 "|" R)))
    (3 (("B" H "|" N)
        ("|" 4 "|" R)))
    (4 (("B" 4 "|" L)
        ("|" 2 "B" L)))))

(define busy-beaver-5 ; h„lt nach 134.467 !!! Schritten, mit 501 Strichen.
                      ; Warnung, Ablauf dauert ca. 1/4 Ewigkeit.
  '(1 H
    (1 (("B" 2 "|" R)
        ("|" 3 "B" L)))
    (2 (("B" 3 "|" R)
        ("|" 4 "|" R)))
    (3 (("B" 1 "|" L)
        ("|" 2 "B" R)))
    (4 (("B" 5 "B" R)
        ("|" H "|" N)))
    (5 (("B" 3 "|" L)
        ("|" 1 "|" R)))))

(define lazy-beaver-5 ; h„lt nach 187 Schritten ohne einen Strich.
  '(1 H
    (1 (("B" 2 "B" R)
        ("|" 1 "B" L)))
    (2 (("B" 3 "B" R)
        ("|" H "B" N)))
    (3 (("B" 4 "|" R)
        ("|" 5 "|" L)))
    (4 (("B" 1 "|" L)
        ("|" 4 "B" L)))
    (5 (("B" 3 "|" R)
        ("|" 5 "|" R)))))

; --------------------------------------------------------------------------
; **************************************************************************
; --------------------------------------------------------------------------

(set-debuglevel! 2)
(debug-on)

(define (add-one s)
  (turing (make-tape s) add-1))

(define (shift-right s)
  (turing (make-tape s) shift-2-right))

(define (b-b-3)
  (turing (make-tape "") busy-beaver-3))

(define (b-b-4)
  (turing (make-tape "") busy-beaver-4))

(define (l-b-5)
  (turing (make-tape "") lazy-beaver-5))