; traveling salesman: nearest neighbor
(define (remove x xs)
(let loop ((xs xs) (zs '()))
(cond ((null? xs) zs)
((equal? (car xs) x) (loop (cdr xs) zs))
(else (loop (cdr xs) (cons (car xs) zs))))))
(define (make-matrix rows columns . value)
(do ((m (make-vector rows)) (i 0 (+ i 1)))
((= i rows) m)
(if (null? value)
(vector-set! m i (make-vector columns))
(vector-set! m i (make-vector columns (car value))))))
(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
(define rand
(let* ((a 3141592653) (c 2718281829)
(m (expt 2 35)) (x 5772156649)
(next (lambda ()
(let ((x-prime (modulo (+ (* a x) c) m)))
(set! x x-prime) x-prime)))
(k 103)
(v (list->vector (reverse
(let loop ((i k) (vs (list x)))
(if (= i 1) vs
(loop (- i 1) (cons (next) vs)))))))
(y (next))
(init (lambda (s)
(set! x s) (vector-set! v 0 x)
(do ((i 1 (+ i 1))) ((= i k))
(vector-set! v i (next))))))
(lambda seed
(cond ((null? seed)
(let* ((j (quotient (* k y) m))
(q (vector-ref v j)))
(set! y q)
(vector-set! v j (next)) (/ y m)))
((eq? (car seed) 'get) (list a c m x y k v))
((eq? (car seed) 'set)
(let ((state (cadr seed)))
(set! a (list-ref state 0))
(set! c (list-ref state 1))
(set! m (list-ref state 2))
(set! x (list-ref state 3))
(set! y (list-ref state 4))
(set! k (list-ref state 5))
(set! v (list-ref state 6))))
(else (init (modulo (numerator
(inexact->exact (car seed))) m))
(rand))))))
(define (randint . args)
(cond ((null? (cdr args))
(floor (* (rand) (car args))))
((< (car args) (cadr args))
(+ (floor (* (rand) (- (cadr args) (car args)))) (car args)))
(else (+ (ceiling (* (rand) (- (cadr args) (car args)))) (car args)))))
(define (n p) (vector-ref p 0))
(define (x p) (vector-ref p 1))
(define (y p) (vector-ref p 2))
(define (make-tsp n)
(define n10 (* n 10))
(let loop ((n (- n 1)) (ps '()))
(if (negative? n) ps
(let ((p (vector n (randint n10) (randint n10))))
(if (member p ps) (loop n ps)
(loop (- n 1) (cons p ps)))))))
(define dists #f)
(define (dist a b)
(define (square x) (* x x))
(when (negative? (matrix-ref dists (n a) (n b)))
(let ((d (sqrt (+ (square (- (x a) (x b)))
(square (- (y a) (y b)))))))
(matrix-set! dists (n a) (n b) d)
(matrix-set! dists (n b) (n a) d)))
(matrix-ref dists (n a) (n b)))
(define (nearest p ps)
(let loop ((ps ps) (min-p #f) (min-d #f))
(cond ((null? ps) min-p)
((or (not min-d) (< (dist p (car ps)) min-d))
(loop (cdr ps) (car ps) (dist p (car ps))))
(else (loop (cdr ps) min-p min-d)))))
(define (tsp ps)
(let ((len (length ps)))
(set! dists (make-matrix len len -1)))
(let loop ((tour (list (car ps))) (unvisited (cdr ps)))
(if (null? unvisited) tour
(let ((next (nearest (car tour) unvisited)))
(loop (cons next tour) (remove next unvisited))))))
(define (cost tour)
(if (or (null? tour) (null? (cdr tour))) 0
(let ((start (car tour)))
(let loop ((tour tour) (sum 0))
(if (null? (cdr tour))
(+ sum (dist (car tour) start))
(loop (cdr tour) (+ sum (dist (car tour) (cadr tour)))))))))
(define ps (make-tsp 25))
(display ps) (newline)
(define t (tsp ps))
(display t) (newline)
(display (cost t)) (newline)