/usr/lib/t-sort.scm is in scheme9 2013.11.26-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (t-sort procedure1 object procedure2 <option> ...) ==> list
; (t-sort-net procedure^2 list <option> ...) ==> list
;
; Sort the directed acyclic graph (DAG) LIST topologically in
; such a way that all dependencies of the first node in the DAG
; (called the "goal") are resolved. PROCEDURE^2 is used to identify
; nodes in the DAG.
;
; A DAG is represented by a list of lists of the form
;
; ((<name-1> <ref> ...)
; ...
; (<name-N> <ref> ...))
;
; where each <name-I> names a node of the DAG and each <ref>
; names a child of the node. Node <name-I> is said to depend on
; each <ref> in the same sublist. A node with zero <ref>s is a
; leaf node.
;
; When the 'STRICT keyword with a #T value is passed as an option
; argument to T-SORT-NET, it will operate in "strict mode" where each
; <ref> in the DAG must have a corresponding node. In non-strict
; operation undefined <ref>s are assumed to be leaves.
;
; T-SORT-NET returns #F when it cannot sort a given DAG, either because
; it contains undefined <refs> in strict mode or because it cycles (and
; hence is not a DAG at all).
;
; When 'CHECK #T is passed as an option to T-SORT-NET, it will return
; more useful information in case of an error, namely
;
; (cyclic . name) when the graph cycles through NAME
; (undefined . name) when node NAME is undefined.
;
; The result can be distinguished from success by the fact that
; the cdr of a negative result is not a pair.
;
; When the 'REVERSE #T option is passed to T-SORT-NET, it will list
; each dependent object before its dependencies.
;
; When the 'TOP-DOWN #T option is passed to T-SORT-NET, it will
; preserve the order of dependencies and the hierarchy of the
; net to sort, i.e. objects closer to the goal will appear last
; in the resulting list (or first, if 'REVERSE #T is also given).
;
; T-SORT is a more general version of T-SORT-NET that allows to sort
; structures without knowing their exact internal representation.
; PROCEDURE1 is the predicate used to compare objects, like in
; T-SORT-NET. OBJECT is the goal. PROCEDURE2 is a procedure that maps
; objects to dependencies their associated dependencies. The procedure
; should return #F when a dependency cannot be resolved. In case of
; success, it delivers a list of the form
;
; (goal object ...)
;
; GOAL is the goal that has been looked up and each OBJECT is an
; object on which the goal depends.
;
; Example: (t-sort-net eq?
; '((dressed shoes hat)
; (shoes socks pants)
; (pants underpants)
; (hat pullover)
; (pullover shirt undershirt)
; (shirt undershirt)
; (underpants))) ==> (socks underpants pants
; shoes undershirt shirt
; pullover hat dressed)
;
; (let ((db '((a b c)
; (b u)
; (c v)
; (u x)
; (v y)
; (w z))))
; (t-sort eq? 'a (lambda (x)
; (assq x db))
; 'top-down #t
; 'reverse #t)) ==> (a b c u v x y)
;
; (t-sort-net eq? '((a b c d))) ==> (b c d a)
; (t-sort-net eq? '((a b c d)) 'strict #t) ==> #f
; (t-sort-net eq? '((a b) (b a))) ==> #f
; (t-sort-net eq? '((foo foo)) 'check #t) ==> (cyclic . foo)
(load-from-library "letcc.scm")
(load-from-library "assp.scm")
(load-from-library "memp.scm")
(load-from-library "hash-table.scm")
(load-from-library "keyword-value.scm")
(load-from-library "id.scm")
(define (t-sort p goal lookup . opts)
(let/cc exit
(let ((visited (make-hash-table 'test p))
(_ (accept-keywords "t-sort"
opts
'(strict check reverse top-down)))
(strict (keyword-value opts 'strict #f))
(check (keyword-value opts 'check #f))
(rev-order (keyword-value opts 'reverse #f))
(top-down (keyword-value opts 'top-down #f)))
(letrec
((find-dep
(lambda (x)
(cond ((lookup x)
=> id)
(strict
(exit (if check
`(undefined . ,dep)
#f)))
(else
'()))))
(sort-bu
(lambda (dep)
(cond ((pair? dep)
(let ((res (apply append (map sort-bu (cdr dep)))))
(if (memp p (car dep) res)
(exit (if check
`(cyclic . ,(car dep))
#f)))
(if rev-order
(append (list (car dep)) res)
(append res (list (car dep))))))
((hash-table-ref visited dep)
'())
(else
(hash-table-set! visited dep #t)
(let ((new-dep (find-dep dep)))
(cond ((null? new-dep)
(list dep))
((null? (cdr new-dep))
(list (car new-dep)))
(else
(sort-bu new-dep))))))))
(sort-td
(lambda (dep)
(cond ((pair? dep)
(if (hash-table-ref visited dep)
(exit (if check
`(cyclic . ,dep)
#f)))
(hash-table-set! visited dep #t)
(let* ((res (map sort-td dep))
(res (map (lambda (x)
(if (null? x)
'()
(cdr x)))
res))
(res (apply append res)))
(append dep (sort-td res))))
(else
(find-dep dep))))))
(if top-down
(let* ((dep (find-dep goal))
(res (cons (car dep) (sort-td (cdr dep))))
(res (list->set res)))
(if rev-order
res
(reverse res)))
(sort-bu (find-dep goal)))))))
(define (t-sort-net p net . opts)
(apply t-sort p
(caar net)
(lambda (x)
(assp p x net))
opts))
|