; penniless pilgrim
(define (add2 x) (+ x 2))
(define (sub2 x) (- x 2))
(define (halve x) (/ x 2))
(define (double x) (* x 2))
(define grid `(
(A (B ,add2) (F ,double) )
(B (A ,sub2) (C ,add2) (G ,double) )
(C (B ,sub2) (D ,add2) (H ,double) )
(D (C ,sub2) (E ,add2) (I ,double) )
(E (D ,sub2) (K ,double) )
(F (A ,halve) (G ,add2) (L ,double) )
(G (B ,halve) (F ,sub2) (H ,add2) (M ,double))
(H (C ,halve) (G ,sub2) (I ,add2) (N ,double))
(I (D ,halve) (H ,sub2) (K ,add2) (O ,double))
(K (E ,halve) (I ,sub2) (P ,double) )
(L (F ,halve) (M ,add2) (Q ,double) )
(M (G ,halve) (L ,sub2) (N ,add2) (R ,double))
(N (H ,halve) (M ,sub2) (O ,add2) (S ,double))
(O (I ,halve) (N ,sub2) (P ,add2) (T ,double))
(P (K ,halve) (O ,sub2) (U ,double) )
(Q (L ,halve) (R ,add2) (V ,double) )
(R (M ,halve) (Q ,sub2) (S ,add2) (W ,double))
(S (N ,halve) (R ,sub2) (T ,add2) (X ,double))
(T (O ,halve) (S ,sub2) (U ,add2) (Y ,double))
(U (P ,halve) (T ,sub2) (Z ,double) )
(V (Q ,halve) (W ,add2) )
(W (R ,halve) (V ,sub2) (X ,add2) )
(X (S ,halve) (W ,sub2) (Y ,add2) )
(Y (T ,halve) (X ,sub2) (Z ,add2) )
(Z (U ,halve) (Y ,sub2) )))
(define (follows? y x xs) ; does y follow x in list xs?
(if (null? xs) #f
(let loop ((xs xs))
(cond ((null? (cdr xs)) #f)
((and (equal? (car xs) x) (equal? (cadr xs) y)) #t)
(else (loop (cdr xs)))))))
(define (visited? from to path)
(or (follows? from to path) (follows? to from path)))
(define (extend cost-and-path paths)
(let ((cost (car cost-and-path))
(path (cdr cost-and-path))
(neighbors (cdr (assoc (cadr cost-and-path) grid))))
(let loop ((neighbors neighbors) (paths paths))
(cond ((null? neighbors) paths)
((not (visited? (car path) (caar neighbors) path))
(loop (cdr neighbors)
(cons (cons ((cadar neighbors) cost)
(cons (caar neighbors) path))
paths)))
(else (loop (cdr neighbors) paths))))))
(define (pilgrim paths)
(let loop ((paths paths))
(if (null? paths) #f
(let ((path (car paths)))
(if (and (zero? (car path)) (equal? (cadr path) 'Z))
(reverse (cdr path))
(loop (extend path (cdr paths))))))))
(display (pilgrim (cons '(4 C B A) (list)))) (newline)