Unnamed

(define-structure tape cells pos)

(define (print-chars tape chars)
  (if (null? chars)
      ""
      (shortest
       (map (lambda (using-cell)
	      (let* ((data (print-char tape (car chars) using-cell))
		     (new-tape (cdr data))
		     (code (car data)))
		(string-append code
			       (print-chars new-tape (cdr chars)))))
	    (from-to 0 (- (vector-length (tape-cells tape)) 1))))))

      
(define (print-char tape char using-cell)
  (cons 
   (string-append (if (< using-cell (tape-pos tape))
		      (make-string (- (tape-pos tape) using-cell) #\<)
		      (make-string (- using-cell (tape-pos tape)) #\>))
		  (if (< char (vector-ref (tape-cells tape) using-cell))
		      (make-string (- (vector-ref (tape-cells tape) using-cell) char) #\-)
		      (make-string (- char (vector-ref (tape-cells tape) using-cell)) #\+))
		  ".")
   (make-tape (let ((v (vector-copy (tape-cells tape))))
		(vector-set! v using-cell char)
		v)
	      using-cell)))

(define (from-to n m)
  (if (= n m)
      (list n)
      (cons n (from-to (+ n 1) m))))

(define (shortest lst)
  (let loop ((lst lst)
	     (shortest #f)
	     (len #f))
    (cond ((null? lst) shortest)
	  ((or (not shortest) (< (string-length (car lst)) len))
	   (loop (cdr lst)
		 (car lst)
		 (string-length (car lst))))
	  (else (loop (cdr lst) shortest len)))))


(define (initialize-factors factor num)
  (make-factors (make-tape (let ((v (make-vector (+ num 1) 0))) (vector-set! v 0 factor) v)
			   0)
		factor
		num))


  
(define (make-factors tape factor num)
  (set! tape (make-tape (vector-copy (tape-cells tape)) (tape-pos tape)))
  (let loop ((i 1))
    (if (< i (+ num 1))
	(begin
	  (vector-set! (tape-cells tape)
		       i
		       (* i (vector-ref (tape-cells tape) (tape-pos tape))))
	  (loop (+ i 1)))))
  (vector-set! (tape-cells tape) (tape-pos tape) 0)
  (cons tape
	(call-with-output-string
	 (lambda (out)
	   (write-string (make-string factor #\+) out)
	   (write-string "[" out)
	   (let loop ((n 1))
	     (if (> n num)
		 (write-string (make-string num #\<) out)
		 (begin (write-string ">" out)
			(write-string (make-string n #\+) out)
	       (loop (+ n 1)))))
	   (write-string "-]" out)))))


(define (print-string string)
  (shortest
   (map
    (lambda (factor)
      (let* ((data (initialize-factors factor (min (min 8 (floor (/ 256 factor))))))
	     (tape (car data))
	     (code (cdr data)))
	(string-append code
		       (print-chars tape
				    (map char->integer
					 (string->list string))))))
    (from-to 2 256))))