(define-syntax while (syntax-rules () ((while test body ...) (let loop () (if test (begin body ... (loop))))))) (define (gray-code n k) ;--> (n k) gray code (define g (make-vector k 0)) (define u (make-vector k 1)) (cons (vector->list g) (let loop () (let/ec ec (let ((i 0) (j (+ (vector-ref g 0) (vector-ref u 0)))) (while (or (>= j n) (< j 0)) (vector-set! u i (- (vector-ref u i))) (set! i (add1 i)) (if (>= i k) (ec ())) (set! j (+ (vector-ref g i) (vector-ref u i)))) (vector-set! g i j) (cons (reverse (vector->list g)) (loop))))))) ; For example: (write (gray-code 4 3)) ;--> ((0 0 0) (0 0 1) (0 0 2) (0 0 3) (0 1 3) (0 1 2) (0 1 1) (0 1 0) (0 2 0) (0 2 1) (0 2 2) (0 2 3) (0 3 3) (0 3 2) (0 3 1) (0 3 0) (1 3 0) (1 3 1) (1 3 2) (1 3 3) (1 2 3) (1 2 2) (1 2 1) (1 2 0) (1 1 0) (1 1 1) (1 1 2) (1 1 3) (1 0 3) (1 0 2) (1 0 1) (1 0 0) (2 0 0) (2 0 1) (2 0 2) (2 0 3) (2 1 3) (2 1 2) (2 1 1) (2 1 0) (2 2 0) (2 2 1) (2 2 2) (2 2 3) (2 3 3) (2 3 2) (2 3 1) (2 3 0) (3 3 0) (3 3 1) (3 3 2) (3 3 3) (3 2 3) (3 2 2) (3 2 1) (3 2 0) (3 1 0) (3 1 1) (3 1 2) (3 1 3) (3 0 3) (3 0 2) (3 0 1) (3 0 0)) (define (number->gray-code m n k) ; m n k --> m-th element of (n,k) gray code (let ((2n (* 2 n))) (let loop ((m m) (k k) (gc ())) (if (zero? k) gc (let ((q (quotient m n)) (r (modulo m 2n))) (loop q (sub1 k) (cons (if (>= r n) (- 2n r 1) r) gc))))))) ; With its inverse: (define (gray-code->number gc n) ; m-th (n,k) gray-code --> m (let loop ((gc gc) (significance (expt n (sub1 (length gc))))) (if (null? gc) 0 (let ((digit (car gc)) (gc (cdr gc))) (let ((m (loop gc (quotient significance n)))) (+ (* digit significance) (if (odd? digit) (- significance m 1) m))))))) (number->gray-code 10 4 3) ;--> (0 2 2) (gray-code->number '(0 2 2) 4) ;--> 10
(gray-code 3 h) shows how to move a Tower of h disks from peg 0 to peg 2 passing every other feasible distribition of disks exactly once (Hamilton path)
| CookbookForm | |
|---|---|
| TopicType: | Recipe |
| ParentTopic: | NumberRecipes |
| TopicOrder: | 999 |