Changeset 15527 in project

Timestamp:

08/21/09 12:08:40 (11 years ago)

Author:

felix winkelmann

Message:

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

Location:

chicken/trunk

Files:

• chicken-install.scm (modified) (5 diffs)
• compiler-namespace.scm (modified) (1 diff)
• data-structures.import.scm (modified) (1 diff)
• data-structures.scm (modified) (1 diff)
• distribution/manifest (modified) (1 diff)
• manual/Unit data-structures (modified) (1 diff)
• manual/Unit posix (modified) (1 diff)
• support.scm (modified) (1 diff)
• types.db (modified) (1 diff)

chicken/trunk/chicken-install.scm

@@ -132 +132 @@
           (else #f)))
 
+  (define (meta-dependencies meta)
+    (append
+     (deps 'depends meta)
+     (deps 'needs meta)
+     (if *run-tests* (deps 'test-depends meta) '())))
+
   (define (outdated-dependencies meta)
-    (let ((ds (append
-               (deps 'depends meta)
-               (deps 'needs meta)
-               (if *run-tests* (deps 'test-depends meta) '()))))
+    (let ((ds (meta-dependencies meta)))
       (let loop ((deps ds) (missing '()) (upgrade '()))
         (if (null? deps)
@@ -172 +175 @@
 
   (define *eggs+dirs+vers* '())
+  (define *dependencies* '())
   (define *checked* '())
   (define *csi* (shellpath (make-pathname *program-path* "csi")))
@@ -239 +243 @@
                   (unless dir (error "extension or version not found"))
                   (print " " name " located at " dir)
-                  (set! *eggs+dirs+vers* (alist-cons name (list dir ver) *eggs+dirs+vers*)) ) ) ] ) )
+                  (set! *eggs+dirs+vers* (cons (list name dir ver) *eggs+dirs+vers*)) ) ) ] ) )
      eggs)
     (unless *retrieve-only*
@@ -251 +255 @@
                       (print "checking dependencies for `" (car e+d+v) "' ...")
                       (let-values ([(missing upgrade) (outdated-dependencies meta)])
+                        (set! *dependencies*
+                          (cons
+                           (cons (car e+d+v) (append missing upgrade))
+                           *dependencies*))
                         (when (pair? missing)
                           (print " missing: " (string-intersperse missing ", "))
@@ -289 +297 @@
     (retrieve eggs)
     (unless *retrieve-only*
-      (for-each ; we assume the order reflects the dependency tree...
-       (lambda (e+d+v)
-         (print "installing " (car e+d+v) #\: (caddr e+d+v) " ...")
-         (print "changing current directory to " (cadr e+d+v))
-         (parameterize ((current-directory (cadr e+d+v)))
-           (let ([cmd (make-install-command e+d+v)])
-             (print "  " cmd)
-             ($system cmd))
-           (when (and *run-tests*
-                      (file-exists? "tests")
-                      (directory? "tests")
-                      (file-exists? "tests/run.scm") )
-             (current-directory "tests")
-             (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d+v))))
-               (print "  " cmd)
-               ($system cmd)))))
-       *eggs+dirs+vers*)))
+      (let ((dag (reverse (topological-sort *dependencies* string=?))))
+        (print "install order:")
+        (pp dag)
+        (for-each
+         (lambda (e+d+v)
+           (print "installing " (car e+d+v) #\: (caddr e+d+v) " ...")
+           (print "changing current directory to " (cadr e+d+v))
+           (parameterize ((current-directory (cadr e+d+v)))
+             (let ([cmd (make-install-command e+d+v)])
+               (print "  " cmd)
+               ($system cmd))
+             (when (and *run-tests*
+                        (file-exists? "tests")
+                        (directory? "tests")
+                        (file-exists? "tests/run.scm") )
+               (current-directory "tests")
+               (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d+v))))
+                 (print "  " cmd)
+                 ($system cmd)))))
+         (map (cut assoc <> *eggs+dirs+vers*) dag)))))
 
   (define (cleanup)

chicken/trunk/compiler-namespace.scm

@@ -275 +275 @@
  toplevel-lambda-id
  toplevel-scope
- topological-sort
  transform-direct-lambdas!
  tree-copy

chicken/trunk/data-structures.import.scm

@@ -75 +75 @@
    sort!
    sorted?
+   topological-sort
    string-chomp
    string-chop

chicken/trunk/data-structures.scm

@@ -781 +781 @@
 
 
+;;;  Simple topological sort:
+;
+; Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
+
+(define (topological-sort dag pred)
+  (if (null? dag)
+      '()
+      (let* ((adj-table '())
+             (sorted '()))
+
+        (define (insert x y)
+          (let loop ([at adj-table])
+            (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
+                  [(pred x (caar at)) (set-cdr! (car at) y)]
+                  [else (loop (cdr at))] ) ) )
+        
+        (define (lookup x)
+          (let loop ([at adj-table])
+            (cond [(null? at) #f]
+                  [(pred x (caar at)) (cdar at)]
+                  [else (loop (cdr at))] ) ) )
+        
+        (define (visit u adj-list)
+          ;; Color vertex u
+          (insert u 'colored)
+          ;; Visit uncolored vertices which u connects to
+          (for-each (lambda (v)
+                      (let ((val (lookup v)))
+                        (if (not (eq? val 'colored))
+                            (visit v (or val '())))))
+                    adj-list)
+          ;; Since all vertices downstream u are visited
+          ;; by now, we can safely put u on the output list
+          (set! sorted (cons u sorted)) )
+        
+        ;; Hash adjacency lists
+        (for-each (lambda (def) (insert (car def) (cdr def)))
+                  (cdr dag))
+        ;; Visit vertices
+        (visit (caar dag) (cdar dag))
+        (for-each (lambda (def)
+                    (let ((val (lookup (car def))))
+                      (if (not (eq? val 'colored))
+                          (visit (car def) (cdr def)))))
+                  (cdr dag)) 
+        sorted) ) )
+
+
 ;;; Binary search:
 

chicken/trunk/distribution/manifest

@@ -193 +193 @@
 srfi-18.scm
 srfi-4.scm
+toposort.scm
 stub.scm
 support.scm

chicken/trunk/manual/Unit data-structures

@@ -251 +251 @@
 Returns true if the list or vector {{SEQUENCE}} is already sorted.
 
+
+==== topological-sort
+
+ [procedure] (topological-sort DAG PRED)
+
+Sorts the directed acyclic graph dag {{DAG}} so that for every edge from vertex
+u to v, u will come before v in the resulting list of vertices.
+
+{{DAG}} is a list of sublists. The car of each sublist is a
+vertex. The cdr is the adjacency list of that vertex, i.e. a list of
+all vertices to which there exists an edge from the car vertex.
+{{pred}} is procedure of two arguments that should compare vertices
+for equality.
+
+Time complexity: O (|V| + |E|)
+
+<enscript highlight=scheme>
+(require 'tsort)
+(topological-sort
+       '((shirt tie belt)
+         (tie jacket)
+         (belt jacket)
+         (watch)
+         (pants shoes belt)
+         (undershorts pants shoes)
+         (socks shoes))
+       eq?)
+
+=>
+
+(socks undershorts pants shoes watch shirt belt tie jacket)
+</enscript>
 
 

chicken/trunk/manual/Unit posix

@@ -988 +988 @@
 ==== time->string
 
-<procedure>(time->string VECTOR)</procedure>
+<procedure>(time->string VECTOR [FORMAT])</procedure>
 
 Converts the broken down time represented in the 10 element vector

chicken/trunk/support.scm

@@ -1127 +1127 @@
 
 
-;;; Simple topological sort:
-;
-; - Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
-
-(define (topological-sort dag pred)
-  (if (null? dag)
-      '()
-      (let* ((adj-table '())
-             (sorted '()))
-
-        (define (insert x y)
-          (let loop ([at adj-table])
-            (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
-                  [(pred x (caar at)) (set-cdr! (car at) y)]
-                  [else (loop (cdr at))] ) ) )
-        
-        (define (lookup x)
-          (let loop ([at adj-table])
-            (cond [(null? at) #f]
-                  [(pred x (caar at)) (cdar at)]
-                  [else (loop (cdr at))] ) ) )
-        
-        (define (visit u adj-list)
-          ;; Color vertex u
-          (insert u 'colored)
-          ;; Visit uncolored vertices which u connects to
-          (for-each (lambda (v)
-                      (let ((val (lookup v)))
-                        (if (not (eq? val 'colored))
-                            (visit v (or val '())))))
-                    adj-list)
-          ;; Since all vertices downstream u are visited
-          ;; by now, we can safely put u on the output list
-          (set! sorted (cons u sorted)) )
-        
-        ;; Hash adjacency lists
-        (for-each (lambda (def) (insert (car def) (cdr def)))
-                  (cdr dag))
-        ;; Visit vertices
-        (visit (caar dag) (cdar dag))
-        (for-each (lambda (def)
-                    (let ((val (lookup (car def))))
-                      (if (not (eq? val 'colored))
-                          (visit (car def) (cdr def)))))
-                  (cdr dag)) 
-        sorted) ) )
-
-
 ;;; Some pathname operations:
 

chicken/trunk/types.db

@@ -452 +452 @@
 (sort! (procedure sort! ((or list vector) (procedure (* *) *)) (or list vector)))
 (sorted? (procedure sorted? ((or list vector) (procedure (* *) *)) boolean))
+(topological-sort (procedure topological-sort (list (procedure (* *) *)) list))
 (string-chomp (procedure string-chomp (string #!optional string) string))
 (string-chop (procedure string-chop (string fixnum) list))