[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Nov 17:
; topological sort

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(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 (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (cyclic? edges)
  (define (leaf edges)
    (let loop ((froms (unique = (sort < (map car edges))))
               (tos (unique = (sort < (map cdr edges)))))
      (cond ((null? froms) (if (pair? tos) (car tos) #f))
            ((null? tos) #f)
            ((< (car froms) (car tos)) (loop (cdr froms) tos))
            ((< (car tos) (car froms)) (car tos))
            (else (loop (cdr froms) (cdr tos))))))
  (define (rem-tos t edges)
    (let loop ((edges edges) (zs '()))
      (cond ((null? edges) zs)
            ((= (cdar edges) t) (loop (cdr edges) zs))
            (else (loop (cdr edges) (cons (car edges) zs))))))
  (let loop ((edges edges))
    (if (null? edges) #f
      (let ((t (leaf edges)))
        (if (not t) #t
          (loop (rem-tos t edges)))))))

(define (tsort gs)
  (define (adj x)
    (map cdr (filter (lambda (xs) (= (car xs) x)) gs)))
  (if (cyclic? gs) (error 'tsort "cyclic")
    (let ((xs (unique = (sort < (map car gs)))))
      (let loop ((xs xs) (zs '()))
        (cond ((null? xs) zs)
              ((member (car xs) zs)
                (loop (cdr xs) zs))
              (else (loop (cdr xs)
                          (cons (car xs)
                                (loop (adj (car xs))
                                      zs)))))))))

(define g '((3 . 8) (3 . 10) (5 . 11) (7 . 8)
  (7 . 11) (8 . 9) (11 . 2) (11 . 9) (11 . 10)))

(display (cyclic? g)) (newline)

(display (cyclic? (append g '((10 . 5))))) (newline)

(display (tsort g)) (newline)


Output:
1
2
3
#f
#t
(7 5 11 2 3 10 8 9)


Create a new paste based on this one


Comments: