;turing-machine-simulation
;Some data definitions
;A program is list of instruction
;A instruction is
; (list state read-sym write-sym direction nxt-state)
(define BLANK '-)
;A tape structure simulating infinite tape
;empty lists represents infinite blanks.
(define-struct tape (left current right))
;A tape is structure (make-tape l c r) :
; where c is a symbol , l is list of symbols ,and r is list of symbols
;
;tape related stuff
;top : (listof any) -> any
;to return the first element of a lst or
;returns BLANK symbol if lst is empty
(define (top lst)
(cond
[(empty? lst) BLANK]
[else (first lst)]))
;remove : (listof any) -> (listof any)
;to return the rest of lst
(define (remove-first lst)
(cond
[(empty? lst) empty]
[else (rest lst)]))
;move-right : tape -> tape
;to move the tape to right by a cell
;i.e shift current to left ;shift right to current
;remove first from right.
(define (move-right a-tape)
(let ([current (tape-current a-tape)])
(make-tape
(cons current (tape-left a-tape))
(top (tape-right a-tape))
(remove-first (tape-right a-tape)))))
;move-left : tape -> tape
;to move the tape to left by a cell
;i.e shift current to right ; shift left to current ;
;remove first from left
(define (move-left a-tape)
(let ([current (tape-current a-tape)]
[left-top (top (tape-left a-tape))])
(make-tape
(remove-first (tape-left a-tape))
left-top
(cons current (tape-right a-tape)))))
;write-sym : any tape -> tape
;to write a sym at current pos in tape
(define (write-sym sym a-tape)
(make-tape
(tape-left a-tape)
sym
(tape-right a-tape)))
;instruction and program related stuff
;get-instr : program state any -> instr or false
;to return a instruction which matches the current-state
;and read-sym from prog.
(define (get-instr prog current-state read-sym)
(ormap
(lambda (instr)
(if (and (equal? current-state (first instr))
(equal? read-sym (second instr))) instr #f )) prog))
;move? : symbol -> (tape->tape)
;given a direction returns the appropiate fucntion
(define (move? direction)
(if (equal? 'R direction)
move-right
move-left))
;same-instruction? : instruction state tape -> boolean
;to determine if instr's matches current-state and
;position of tape.
(define (same-instruction? instr current-state a-tape)
(and
(equal? (first instr) current-state)
(equal? (second instr) (tape-current a-tape))))
;perform-instruction : program instruction tape -> tape
;to execute prog's instr on a-tape.
(define (perform-instruction prog instr a-tape)
(let ([write-s (third instr)]
[move-tape (move? (fourth instr))]
[nxt-state (fifth instr)])
(let ([moved-tape (move-tape (write-sym write-s a-tape ))])
(if (same-instruction? instr nxt-state moved-tape)
(begin (printf "Executing Instruction ~s on tape " instr)
(print-tape moved-tape)
(perform-instruction prog instr moved-tape))
(perform prog moved-tape nxt-state)))))
;perform : program tape state -> tape
;to execute the program on a-tape from a current-state
(define (perform program a-tape current-state)
(cond
[(= -1 current-state) a-tape]
[else (let ([instr (get-instr program current-state (tape-current a-tape))])
(printf "Executing Instruction ~s on tape " instr)
(print-tape a-tape)
(let ([t (perform-instruction program instr a-tape)])
t))]))
;utils , for printing
;handles only symbol and numbers
(define (make-head current)
(cond
[(symbol? current) (string->symbol
(string-append "[" (symbol->string current) "]"))]
[else (string-append "[" (number->string current) "]")]))
;dump the tape
(define (print-tape a-tape)
(printf "~s\n" (append (reverse (tape-left a-tape))
(list (make-head (tape-current a-tape)))
(tape-right a-tape))))
;run
(define current-tape (make-tape '() '1 '(1 1 + 1 1 1 1 1 )))
(define instructions '((0 1 1 R 0)
(0 + 1 R 1)
(1 1 1 R 1)
(1 - - L 2)
(2 1 - L -1)))
(print-tape current-tape)
(define t (perform instructions current-tape 0))
(print-tape t)
;output :
;("[1]" 1 1 + 1 1 1 1 1)
;Executing Instruction (0 1 1 R 0) on tape ("[1]" 1 1 + 1 1 1 1 1)
;Executing Instruction (0 1 1 R 0) on tape (1 "[1]" 1 + 1 1 1 1 1)
;Executing Instruction (0 1 1 R 0) on tape (1 1 "[1]" + 1 1 1 1 1)
;Executing Instruction (0 + 1 R 1) on tape (1 1 1 |[+]| 1 1 1 1 1)
;Executing Instruction (1 1 1 R 1) on tape (1 1 1 1 "[1]" 1 1 1 1)
;Executing Instruction (1 1 1 R 1) on tape (1 1 1 1 1 "[1]" 1 1 1)
;Executing Instruction (1 1 1 R 1) on tape (1 1 1 1 1 1 "[1]" 1 1)
;Executing Instruction (1 1 1 R 1) on tape (1 1 1 1 1 1 1 "[1]" 1)
;Executing Instruction (1 1 1 R 1) on tape (1 1 1 1 1 1 1 1 "[1]")
;Executing Instruction (1 - - L 2) on tape (1 1 1 1 1 1 1 1 1 |[-]|)
;Executing Instruction (2 1 - L -1) on tape (1 1 1 1 1 1 1 1 "[1]" -)
;(1 1 1 1 1 1 1 "[1]" - -)