[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/2RPNPlHk    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Mar 28:
; turing machine multiplier

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define blanks
  (let ((x (list #\space)))
    (set-cdr! x x)
    (cons x x)))

(define (read-cell tape) (cadr tape))

(define (write-cell chr tape)
  (cons (car tape) (cons chr (cddr tape))))

(define (move-left tape)
  (cons (cdar tape) (cons (caar tape) (cdr tape))))

(define (move-right tape)
  (cons (cons (cadr tape) (car tape)) (cddr tape)))

(define (make-tape chrs curr)
  (define (insert-cell chr tape)
    (cons (car tape) (cons chr (cdr tape))))
  (let loop ((curr curr) (chrs (reverse (string->list chrs))) (tape blanks))
    (cond ((= curr -1) (move-left tape))
          ((null? chrs) (loop (- curr 1) chrs (move-right tape)))
          (else (loop curr (cdr chrs) (insert-cell (car chrs) tape))))))

(define (show-tape tape)
  (let loop ((tape tape) (k -1))
    (if (char=? (read-cell tape) #\space)
        (let loop ((tape (move-right tape)) (chrs '()))
          (if (char=? (read-cell tape) #\space)
              (values (list->string (reverse chrs)) k)
              (loop (move-right tape) (cons (read-cell tape) chrs))))
        (loop (move-left tape) (+ k 1)))))

(define (hash-state-symbol key)
  (+ (* (car key) 256) (char->integer (cadr key))))

(define (make-prog tuples)
  (let ((prog (make-hash hash-state-symbol equal? #f 97)))
    (do ((tuples tuples (cdr tuples)))
        ((null? tuples) prog)
      (prog 'insert (take 2 (car tuples)) (drop 2 (car tuples))))))

(define (turing prog tape)
  (let loop ((state 0) (tape tape))
    (if (negative? state) (show-tape tape)
      (let ((cmd (prog 'lookup (list state (read-cell tape)))))
        (loop (caddr cmd) (case (cadr cmd)
          ((left) (move-left (write-cell (car cmd) tape)))
          ((right) (move-right (write-cell (car cmd) tape)))
          (else (write-cell (car cmd) tape))))))))

(define multiplier '(            ; product = multiplicand * multiplier
  (0 #\1     #\1     left   0)   ; move left to blank at left of multiplicand
  (0 #\space #\=     right  1)   ; write equal-sign to mark right end of product
  (1 #\1     #\1     right  1)   ; traverse to right end of multiplier
  (1 #\*     #\*     right  1)   ; traverse to right end of multiplier
  (1 #\space #\space left   2)   ; found left end of multiplier
  (2 #\*     #\space left   8)   ; outer loop -- terminates at times-sign
  (2 #\1     #\space left   3)   ; outer loop -- for each digit in multiplier
  (3 #\1     #\1     left   3)   ;     traverse across multiplier
  (3 #\*     #\*     left   4)   ;     found beginning of multiplicand
  (4 #\=     #\=     right  7)   ;     inner loop -- terminates at equal-sign
  (4 #\1     #\@     left   5)   ;     inner loop -- for each digit of multiplicand
  (5 #\1     #\1     left   5)   ;         traverse to left end of product
  (5 #\=     #\=     left   5)   ;         traverse to left end of product
  (5 #\space #\1     right  6)   ;         write new digit at end of product
  (6 #\1     #\1     right  6)   ;         traverse to next digit of multiplicand
  (6 #\=     #\=     right  6)   ;         traverse to next digit of multiplicand
  (6 #\@     #\@     left   4)   ;         go to top of inner loop
  (7 #\@     #\1     right  7)   ;     reset digits of multiplicand
  (7 #\*     #\*     right  7)   ;     traverse to right end of multiplier
  (7 #\1     #\1     right  7)   ;     traverse to right end of multiplier
  (7 #\space #\space left   2)   ;     go to top of outer loop
  (8 #\1     #\space left   8)   ; erase multiplicand
  (8 #\=     #\space left  -1))) ; erase equal-sign and halt

(call-with-values
  (lambda () (turing (make-prog multiplier) (make-tape "111*1111" 0)))
  (lambda (str k) (display str) (newline) (display k) (newline)))


Output:
1
2
111111111111
11


Create a new paste based on this one


Comments: