; stepwise program development: a heuristic algorithm
(define-syntax while
(syntax-rules ()
((while pred? body ...)
(do () ((not pred?)) body ...))))
(define-syntax repeat
(syntax-rules (while until)
((repeat body ... (while pred?))
(let loop () body ...
(when pred? (loop))))
((repeat body ... (until pred?))
(let loop () body ...
(unless pred? (loop))))))
(define (succ c)
(integer->char
(+ (char->integer c) 1)))
(define (wirth n)
(let ((s (make-vector (+ n 1) #f))
(m 0) (good #f))
(define (extend)
(set! m (+ m 1))
(vector-set! s m #\1))
(define (change)
(while (char=? (vector-ref s m) #\3)
(set! m (- m 1)))
(vector-set! s m (succ (vector-ref s m))))
(define (check)
(let ((i 0) (l 0) (mhalf 0))
(set! good #t)
(set! l 0)
(set! mhalf (quotient m 2))
(while (and good (< l mhalf))
(set! l (+ l 1))
(set! i 0)
(repeat
(set! good
(not (char=?
(vector-ref s (- m i))
(vector-ref s (- m l i)))))
(set! i (+ i 1))
(until (or good (= i l)))))))
(define (print)
(do ((i 1 (+ i 1))) ((< n i))
(display (vector-ref s i)))
(newline))
(set! m 2)
(vector-set! s 1 #\1)
(vector-set! s 2 #\2)
(set! good #t)
(repeat
(if good
(if (= m n)
(begin (print) (change))
(extend))
(change))
(check)
(until (= m 2)))))
(wirth 5) (newline)
(wirth 12) (newline)
(wirth 20)
programmingpraxis
-
Scheme,
pasted
on Dec 9: