Changeset 15527 in project for chicken


Ignore:
Timestamp:
08/21/09 12:08:40 (10 years ago)
Author:
felix winkelmann
Message:

added topological-sort to data-structures unit; chicken-install sorts dependencies before installing them

Location:
chicken/trunk
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken-install.scm

    r15171 r15527  
    132132          (else #f)))
    133133
     134  (define (meta-dependencies meta)
     135    (append
     136     (deps 'depends meta)
     137     (deps 'needs meta)
     138     (if *run-tests* (deps 'test-depends meta) '())))
     139
    134140  (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)))
    139142      (let loop ((deps ds) (missing '()) (upgrade '()))
    140143        (if (null? deps)
     
    172175
    173176  (define *eggs+dirs+vers* '())
     177  (define *dependencies* '())
    174178  (define *checked* '())
    175179  (define *csi* (shellpath (make-pathname *program-path* "csi")))
     
    239243                  (unless dir (error "extension or version not found"))
    240244                  (print " " name " located at " dir)
    241                   (set! *eggs+dirs+vers* (alist-cons name (list dir ver) *eggs+dirs+vers*)) ) ) ] ) )
     245                  (set! *eggs+dirs+vers* (cons (list name dir ver) *eggs+dirs+vers*)) ) ) ] ) )
    242246     eggs)
    243247    (unless *retrieve-only*
     
    251255                      (print "checking dependencies for `" (car e+d+v) "' ...")
    252256                      (let-values ([(missing upgrade) (outdated-dependencies meta)])
     257                        (set! *dependencies*
     258                          (cons
     259                           (cons (car e+d+v) (append missing upgrade))
     260                           *dependencies*))
    253261                        (when (pair? missing)
    254262                          (print " missing: " (string-intersperse missing ", "))
     
    289297    (retrieve eggs)
    290298    (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)))))
    308319
    309320  (define (cleanup)
  • chicken/trunk/compiler-namespace.scm

    r15246 r15527  
    275275 toplevel-lambda-id
    276276 toplevel-scope
    277  topological-sort
    278277 transform-direct-lambdas!
    279278 tree-copy
  • chicken/trunk/data-structures.import.scm

    r12937 r15527  
    7575   sort!
    7676   sorted?
     77   topological-sort
    7778   string-chomp
    7879   string-chop
  • chicken/trunk/data-structures.scm

    r13542 r15527  
    781781
    782782
     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
    783831;;; Binary search:
    784832
  • chicken/trunk/distribution/manifest

    r15506 r15527  
    193193srfi-18.scm
    194194srfi-4.scm
     195toposort.scm
    195196stub.scm
    196197support.scm
  • chicken/trunk/manual/Unit data-structures

    r14828 r15527  
    251251Returns true if the list or vector {{SEQUENCE}} is already sorted.
    252252
     253
     254==== topological-sort
     255
     256 [procedure] (topological-sort DAG PRED)
     257
     258Sorts the directed acyclic graph dag {{DAG}} so that for every edge from vertex
     259u 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
     262vertex. The cdr is the adjacency list of that vertex, i.e. a list of
     263all vertices to which there exists an edge from the car vertex.
     264{{pred}} is procedure of two arguments that should compare vertices
     265for equality.
     266
     267Time 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>
    253285
    254286
  • chicken/trunk/manual/Unit posix

    r15321 r15527  
    988988==== time->string
    989989
    990 <procedure>(time->string VECTOR)</procedure>
     990<procedure>(time->string VECTOR [FORMAT])</procedure>
    991991
    992992Converts the broken down time represented in the 10 element vector
  • chicken/trunk/support.scm

    r15246 r15527  
    11271127
    11281128
    1129 ;;; Simple topological sort:
    1130 ;
    1131 ; - Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
    1132 
    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 u
    1153           (insert u 'colored)
    1154           ;; Visit uncolored vertices which u connects to
    1155           (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 visited
    1161           ;; by now, we can safely put u on the output list
    1162           (set! sorted (cons u sorted)) )
    1163        
    1164         ;; Hash adjacency lists
    1165         (for-each (lambda (def) (insert (car def) (cdr def)))
    1166                   (cdr dag))
    1167         ;; Visit vertices
    1168         (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 
    11771129;;; Some pathname operations:
    11781130
  • chicken/trunk/types.db

    r15262 r15527  
    452452(sort! (procedure sort! ((or list vector) (procedure (* *) *)) (or list vector)))
    453453(sorted? (procedure sorted? ((or list vector) (procedure (* *) *)) boolean))
     454(topological-sort (procedure topological-sort (list (procedure (* *) *)) list))
    454455(string-chomp (procedure string-chomp (string #!optional string) string))
    455456(string-chop (procedure string-chop (string fixnum) list))
Note: See TracChangeset for help on using the changeset viewer.