```1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 ``` ```;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]" - -) ```