Changeset 15527 in project
- Timestamp:
- 08/21/09 12:08:40 (10 years ago)
- Location:
- chicken/trunk
- Files:
-
- 9 edited
Legend:
- Unmodified
- Added
- Removed
-
chicken/trunk/chicken-install.scm
r15171 r15527 132 132 (else #f))) 133 133 134 (define (meta-dependencies meta) 135 (append 136 (deps 'depends meta) 137 (deps 'needs meta) 138 (if *run-tests* (deps 'test-depends meta) '()))) 139 134 140 (define (outdated-dependencies meta) 135 (let ((ds (append 136 (deps 'depends meta) 137 (deps 'needs meta) 138 (if *run-tests* (deps 'test-depends meta) '())))) 141 (let ((ds (meta-dependencies meta))) 139 142 (let loop ((deps ds) (missing '()) (upgrade '())) 140 143 (if (null? deps) … … 172 175 173 176 (define *eggs+dirs+vers* '()) 177 (define *dependencies* '()) 174 178 (define *checked* '()) 175 179 (define *csi* (shellpath (make-pathname *program-path* "csi"))) … … 239 243 (unless dir (error "extension or version not found")) 240 244 (print " " name " located at " dir) 241 (set! *eggs+dirs+vers* ( alist-cons name (listdir ver) *eggs+dirs+vers*)) ) ) ] ) )245 (set! *eggs+dirs+vers* (cons (list name dir ver) *eggs+dirs+vers*)) ) ) ] ) ) 242 246 eggs) 243 247 (unless *retrieve-only* … … 251 255 (print "checking dependencies for `" (car e+d+v) "' ...") 252 256 (let-values ([(missing upgrade) (outdated-dependencies meta)]) 257 (set! *dependencies* 258 (cons 259 (cons (car e+d+v) (append missing upgrade)) 260 *dependencies*)) 253 261 (when (pair? missing) 254 262 (print " missing: " (string-intersperse missing ", ")) … … 289 297 (retrieve eggs) 290 298 (unless *retrieve-only* 291 (for-each ; we assume the order reflects the dependency tree... 292 (lambda (e+d+v) 293 (print "installing " (car e+d+v) #\: (caddr e+d+v) " ...") 294 (print "changing current directory to " (cadr e+d+v)) 295 (parameterize ((current-directory (cadr e+d+v))) 296 (let ([cmd (make-install-command e+d+v)]) 297 (print " " cmd) 298 ($system cmd)) 299 (when (and *run-tests* 300 (file-exists? "tests") 301 (directory? "tests") 302 (file-exists? "tests/run.scm") ) 303 (current-directory "tests") 304 (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d+v)))) 305 (print " " cmd) 306 ($system cmd))))) 307 *eggs+dirs+vers*))) 299 (let ((dag (reverse (topological-sort *dependencies* string=?)))) 300 (print "install order:") 301 (pp dag) 302 (for-each 303 (lambda (e+d+v) 304 (print "installing " (car e+d+v) #\: (caddr e+d+v) " ...") 305 (print "changing current directory to " (cadr e+d+v)) 306 (parameterize ((current-directory (cadr e+d+v))) 307 (let ([cmd (make-install-command e+d+v)]) 308 (print " " cmd) 309 ($system cmd)) 310 (when (and *run-tests* 311 (file-exists? "tests") 312 (directory? "tests") 313 (file-exists? "tests/run.scm") ) 314 (current-directory "tests") 315 (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d+v)))) 316 (print " " cmd) 317 ($system cmd))))) 318 (map (cut assoc <> *eggs+dirs+vers*) dag))))) 308 319 309 320 (define (cleanup) -
chicken/trunk/compiler-namespace.scm
r15246 r15527 275 275 toplevel-lambda-id 276 276 toplevel-scope 277 topological-sort278 277 transform-direct-lambdas! 279 278 tree-copy -
chicken/trunk/data-structures.import.scm
r12937 r15527 75 75 sort! 76 76 sorted? 77 topological-sort 77 78 string-chomp 78 79 string-chop -
chicken/trunk/data-structures.scm
r13542 r15527 781 781 782 782 783 ;;; Simple topological sort: 784 ; 785 ; Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt 786 787 (define (topological-sort dag pred) 788 (if (null? dag) 789 '() 790 (let* ((adj-table '()) 791 (sorted '())) 792 793 (define (insert x y) 794 (let loop ([at adj-table]) 795 (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))] 796 [(pred x (caar at)) (set-cdr! (car at) y)] 797 [else (loop (cdr at))] ) ) ) 798 799 (define (lookup x) 800 (let loop ([at adj-table]) 801 (cond [(null? at) #f] 802 [(pred x (caar at)) (cdar at)] 803 [else (loop (cdr at))] ) ) ) 804 805 (define (visit u adj-list) 806 ;; Color vertex u 807 (insert u 'colored) 808 ;; Visit uncolored vertices which u connects to 809 (for-each (lambda (v) 810 (let ((val (lookup v))) 811 (if (not (eq? val 'colored)) 812 (visit v (or val '()))))) 813 adj-list) 814 ;; Since all vertices downstream u are visited 815 ;; by now, we can safely put u on the output list 816 (set! sorted (cons u sorted)) ) 817 818 ;; Hash adjacency lists 819 (for-each (lambda (def) (insert (car def) (cdr def))) 820 (cdr dag)) 821 ;; Visit vertices 822 (visit (caar dag) (cdar dag)) 823 (for-each (lambda (def) 824 (let ((val (lookup (car def)))) 825 (if (not (eq? val 'colored)) 826 (visit (car def) (cdr def))))) 827 (cdr dag)) 828 sorted) ) ) 829 830 783 831 ;;; Binary search: 784 832 -
chicken/trunk/distribution/manifest
r15506 r15527 193 193 srfi-18.scm 194 194 srfi-4.scm 195 toposort.scm 195 196 stub.scm 196 197 support.scm -
chicken/trunk/manual/Unit data-structures
r14828 r15527 251 251 Returns true if the list or vector {{SEQUENCE}} is already sorted. 252 252 253 254 ==== topological-sort 255 256 [procedure] (topological-sort DAG PRED) 257 258 Sorts the directed acyclic graph dag {{DAG}} so that for every edge from vertex 259 u to v, u will come before v in the resulting list of vertices. 260 261 {{DAG}} is a list of sublists. The car of each sublist is a 262 vertex. The cdr is the adjacency list of that vertex, i.e. a list of 263 all vertices to which there exists an edge from the car vertex. 264 {{pred}} is procedure of two arguments that should compare vertices 265 for equality. 266 267 Time complexity: O (|V| + |E|) 268 269 <enscript highlight=scheme> 270 (require 'tsort) 271 (topological-sort 272 '((shirt tie belt) 273 (tie jacket) 274 (belt jacket) 275 (watch) 276 (pants shoes belt) 277 (undershorts pants shoes) 278 (socks shoes)) 279 eq?) 280 281 => 282 283 (socks undershorts pants shoes watch shirt belt tie jacket) 284 </enscript> 253 285 254 286 -
chicken/trunk/manual/Unit posix
r15321 r15527 988 988 ==== time->string 989 989 990 <procedure>(time->string VECTOR )</procedure>990 <procedure>(time->string VECTOR [FORMAT])</procedure> 991 991 992 992 Converts the broken down time represented in the 10 element vector -
chicken/trunk/support.scm
r15246 r15527 1127 1127 1128 1128 1129 ;;; Simple topological sort:1130 ;1131 ; - Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt1132 1133 (define (topological-sort dag pred)1134 (if (null? dag)1135 '()1136 (let* ((adj-table '())1137 (sorted '()))1138 1139 (define (insert x y)1140 (let loop ([at adj-table])1141 (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]1142 [(pred x (caar at)) (set-cdr! (car at) y)]1143 [else (loop (cdr at))] ) ) )1144 1145 (define (lookup x)1146 (let loop ([at adj-table])1147 (cond [(null? at) #f]1148 [(pred x (caar at)) (cdar at)]1149 [else (loop (cdr at))] ) ) )1150 1151 (define (visit u adj-list)1152 ;; Color vertex u1153 (insert u 'colored)1154 ;; Visit uncolored vertices which u connects to1155 (for-each (lambda (v)1156 (let ((val (lookup v)))1157 (if (not (eq? val 'colored))1158 (visit v (or val '())))))1159 adj-list)1160 ;; Since all vertices downstream u are visited1161 ;; by now, we can safely put u on the output list1162 (set! sorted (cons u sorted)) )1163 1164 ;; Hash adjacency lists1165 (for-each (lambda (def) (insert (car def) (cdr def)))1166 (cdr dag))1167 ;; Visit vertices1168 (visit (caar dag) (cdar dag))1169 (for-each (lambda (def)1170 (let ((val (lookup (car def))))1171 (if (not (eq? val 'colored))1172 (visit (car def) (cdr def)))))1173 (cdr dag))1174 sorted) ) )1175 1176 1177 1129 ;;; Some pathname operations: 1178 1130 -
chicken/trunk/types.db
r15262 r15527 452 452 (sort! (procedure sort! ((or list vector) (procedure (* *) *)) (or list vector))) 453 453 (sorted? (procedure sorted? ((or list vector) (procedure (* *) *)) boolean)) 454 (topological-sort (procedure topological-sort (list (procedure (* *) *)) list)) 454 455 (string-chomp (procedure string-chomp (string #!optional string) string)) 455 456 (string-chop (procedure string-chop (string fixnum) list))
Note: See TracChangeset
for help on using the changeset viewer.