[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/tVIXh2TW    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Mar 15:
; 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)


Output:
1
2
3
(#(0 139 31) #(1 41 126) #(2 108 49) #(3 112 193) #(4 179 188) #(5 212 24) #(6 245 50) #(7 167 187) #(8 159 236) #(9 185 78) #(10 27 63) #(11 101 188) #(12 195 167) #(13 30 10) #(14 238 110) #(15 221 60) #(16 27 231) #(17 146 67) #(18 249 172) #(19 36 71) #(20 37 203) #(21 118 38) #(22 241 226) #(23 197 29) #(24 220 186))
(#(22 241 226) #(13 30 10) #(10 27 63) #(19 36 71) #(1 41 126) #(16 27 231) #(20 37 203) #(11 101 188) #(3 112 193) #(8 159 236) #(7 167 187) #(4 179 188) #(12 195 167) #(24 220 186) #(18 249 172) #(14 238 110) #(23 197 29) #(5 212 24) #(6 245 50) #(15 221 60) #(9 185 78) #(17 146 67) #(2 108 49) #(21 118 38) #(0 139 31))
1468.6472491877407


Create a new paste based on this one


Comments: