[ create a new paste ] login | about

Link: http://codepad.org/pb3pJtxl    [ raw code | fork ]

veerandscheme - Scheme, pasted on Mar 27:
;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]" - -)


Create a new paste based on this one


Comments: