[ create a new paste ] login | about

Link: http://codepad.org/TE084ryW    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on May 31:
; the seven bridges of koenigsberg

(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 seven '(
  (a b b c)     ; north shore to west island twice and east island once
  (b a a c d d) ; west island to north shore twice, east island once, and south shore twice
  (c a b d)     ; east island to north shore once, west island once, and south shore once
  (d b b c)))   ; south shore to west island twice and east island once

(define five '(
  (a b c)   ; north shore to west island and east island
  (b a c d) ; west island to north shore, east island and south shore
  (c a b d) ; east island to north shore, west island and south shore
  (d b c))) ; south shore to west island and east island

(define envelope '(
  (a b c)     ; top to top-left, top-right
  (b a c d e) ; top-left to top, top-right, center, bottom-left
  (c a b d f) ; top-right to top, top-left, center, bottom-right
  (d b c e f) ; center to top-left, top-right, bottom-left, bottom-right
  (e b d f)   ; bottom-left to top-left, center, bottom-right
  (f c d e))) ; bottom-right to top-right, center, bottom-left

(define (euler-path? g) ; is there an eulerian path through graph g
  (define (odd-len-cdr? xs) (if (odd? (length (cdr xs))) 1 0))
  (let ((odd-count (apply + (map odd-len-cdr? g))))
    (or (= odd-count 0) (= odd-count 2))))

(define (euler-circuit? g) ; is there an eulerian circuit through graph g
  (define (odd-len-cdr? xs) (if (odd? (length (cdr xs))) 1 0))
  (zero? (apply + (map odd-len-cdr? g))))

(display (euler-path? seven)) (newline)
(display (euler-path? five)) (newline)
(display (euler-circuit? five)) (newline)
(display (euler-path? envelope)) (newline)
(display (euler-circuit? envelope)) (newline)

(define (start g)
  (cond ((null? g) (error 'start "empty graph"))
        ((even? (length (car g))) (caar g)) ; odd-degree vertex
        ((null? (cdr g)) (caar g)) ; even-degree vertex
        (else (start (cdr g)))))

(define (lt? a b) (string<? (symbol->string a) (symbol->string b)))

(define (edges g)
  (let g-loop ((g g) (es (list)))
    (if (null? g) es
      (let v-loop ((v (caar g)) (vs (cdar g)) (es es))
        (if (null? vs) (g-loop (cdr g) es)
          (if (lt? v (car vs))
              (v-loop v (cdr vs) (cons (sort lt? (list v (car vs))) es))
              (v-loop v (cdr vs) es)))))))

(define (neighbor curr edges)
  (let loop ((edges edges))
    (cond ((null? edges) #f)
          ((equal? curr (caar edges)) (cadar edges))
          ((equal? curr (cadar edges)) (caar edges))
          (else (loop (cdr edges))))))

(define (remove-edge edges curr neigh)
  (let ((edge (sort lt? (list curr neigh))))
    (let loop ((edges edges) (result (list)))
      (if (null? edges) result
        (if (equal? (car edges) edge)
            (append (cdr edges) result)
            (loop (cdr edges) (cons (car edges) result)))))))

(define (euler-path g)
  (if (not (euler-path? g)) (error 'euler-path "impossible")
    (let loop ((curr (start g)) (edges (edges g)) (stack (list)) (path (list)))
      (let ((neigh (neighbor curr edges)))
        (cond ((and (null? stack) (not neigh)) (cons curr path))
              ((not neigh) (loop (car stack) edges (cdr stack) (cons curr path)))
              (else (loop neigh (remove-edge edges curr neigh) (cons curr stack) path)))))))

(display (euler-path five)) (newline)
(display (euler-path envelope)) (newline)


Output:
1
2
3
4
5
6
7
#f
#t
#f
#t
#f
(b d c a b c)
(e f d e b d c a b c f)


Create a new paste based on this one


Comments: