[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Apr 8:
; traveling salesman: minimum spanning tree

(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 (remove x xs)
  (let loop ((xs xs) (zs '()))
    (cond ((null? xs) (reverse zs))
          ((equal? (car xs) x) (loop (cdr xs) zs))
          (else (loop (cdr xs) (cons (car xs) zs))))))

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define (make-hash hash eql? oops size)
  (let ((table (make-vector size '())))
    (lambda (message . args)
      (if (eq? message 'enlist)
          (let loop ((k 0) (result '()))
            (if (= size k)
                result
                (loop (+ k 1) (append (vector-ref table k) result))))
          (let* ((key (car args))
                 (index (modulo (hash key) size))
                 (bucket (vector-ref table index)))
            (case message
              ((lookup fetch get ref recall)
                (let loop ((bucket bucket))
                  (cond ((null? bucket) oops)
                        ((eql? (caar bucket) key) (cdar bucket))
                        (else (loop (cdr bucket))))))
              ((insert insert! ins ins! set set! store store! install install!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (cadr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key (cadr args)) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((delete delete! del del! remove remove!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket) '())
                          ((eql? (caar bucket) key)
                            (cdr bucket))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              ((update update!)
                (vector-set! table index
                  (let loop ((bucket bucket))
                    (cond ((null? bucket)
                            (list (cons key (caddr args))))
                          ((eql? (caar bucket) key)
                            (cons (cons key ((cadr args) key (cdar bucket))) (cdr bucket)))
                          (else (cons (car bucket) (loop (cdr bucket))))))))
              (else (error 'hash-table "unrecognized message")) ))))))

(define (identity x) x)

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (make-tsp n)
  (let loop ((k n) (zs '()))
    (if (zero? k) zs
      (let ((z (list (- k 1) (randint (* n 10)) (randint (* n 10)))))
        (if (member (cdr z) (map cdr zs)) (loop k zs)
          (loop (- k 1) (cons z zs)))))))

(define (dist a b)
  (define (square x) (* x x))
  (sqrt (+ (square (- (cadr a) (cadr b)))
           (square (- (caddr a) (caddr b))))))

(define (make-vertices ps) (map car ps))

(define (make-edges ps)
  (list-of (list (dist a b) (car a) (car b))
    (a in ps) (b in ps) (< (car a) (car b))))

(define (make-disjoint-set hash eql? oops size)
  (let ((forest (make-hash hash eql? oops size)))
    (define (make-set item) ; car is parent, cdr is rank
      (forest 'insert item (cons item 0)))
    (define (find item)
      (let ((parent (car (forest 'lookup item))))
        (if (eql? item parent) item
          (let ((x (forest 'lookup (find parent))))
            (forest 'insert item x)
            (car x)))))
    (define (union item1 item2)
      (let* ((root1 (find item1)) (root2 (find item2))
             (rank1 (cdr (forest 'lookup root1)))
             (rank2 (cdr (forest 'lookup root2))))
        (cond ((< rank1 rank2)
                (forest 'insert root1 (cons root2 rank1)))
              ((< rank2 rank1)
                (forest 'insert root2 (cons root1 rank2)))
              ((not (eql? root1 root2))
                (forest 'insert root2 (cons root1 rank2))
                (forest 'insert root1 (cons root1 (+ rank1 1)))))))
    (lambda (message . args)
      (case message
        ((enlist) (forest 'enlist))
        ((make-set) (apply make-set args))
        ((find) (apply find args))
        ((union) (apply union args))))))

(define (kruskal vs es)
  (let ((f (make-disjoint-set identity = #f 19))
        (n (- (length vs) 1))
        (es (sort (lambda (x y) (< (car x) (car y))) es)))
    (do ((vs vs (cdr vs))) ((null? vs))
      (f 'make-set (car vs)))
    (let loop ((es es) (zs '()) (n n))
      (cond ((zero? n) zs)
            ((= (f 'find (cadar es)) (f 'find (caddar es)))
              (loop (cdr es) zs n))
            (else (f 'union (cadar es) (caddar es))
                  (loop (cdr es) (cons (car es) zs) (- n 1)))))))

(define (find x xs)
  (cond ((null? xs) #f)
        ((or (equal? x (caar xs)) (equal? x (cadar xs))) (car xs))
        (else (find x (cdr xs)))))

(define (tsp ps)
  (let loop ((es (map cdr (kruskal (make-vertices ps) (make-edges ps))))
             (vs (list 0)) (zs (list 0)))
    (cond ((null? es) zs)
          ((find (car vs) es) =>
            (lambda (edge)
              (let ((v (if (equal? (car vs) (car edge)) (cadr edge) (car edge))))
                (loop (remove edge es) (cons v vs) (cons v zs)))))
          (else (loop es (cdr vs) zs)))))

(define ps (make-tsp 10))
(display ps) (newline)
(display (tsp ps)) (newline)


Output:
1
2
((0 88 24) (1 11 92) (2 58 26) (3 99 69) (4 14 28) (5 15 81) (6 47 15) (7 96 90) (8 78 11) (9 88 74))
(1 5 4 6 2 8 7 9 3 0)


Create a new paste based on this one


Comments: