codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; 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)
Private
[
?
]
Run code
Submit