scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added a comment, improved error message for unresolveable adjacencies, 

a sort function is now part of this module, so it can be used standing
alone
This commit is contained in:
jottbee 2005-02-14 06:48:08 +00:00
parent a8dd2ab60b
commit 2479676e2d
1 changed files with 32 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
dfs.scm
View File

@ -1,3 +1,28 @@
;;;
;;; merge(?) sort for general purpose:
;;; ==================================
;;;
;;; (sort predicate list-to-be-sorted to-sort-in-list) ---> sorted-list
;;;
;;; where
;;;
;;; predicate : (lambda (a b) ...) with a x b ---> {#t, #f}
;;; e.g. (lambda (a b) (> a b))
;;; list-to-be-sorted : e.g. '(4 2 5 1 3)
;;; to-sort-in-list : e.g. '(6)
;;;
;;; will produce the result '(6 5 4 3 2 1).
;;;
(define (sort pred todo done)
(if (null? todo)
done
(sort pred (cdr todo) (insert pred (car todo) done))))
(define (insert pred item ls)
(if (or (null? ls) (pred item (car ls)))
(cons item ls)
(cons (car ls) (insert pred item (cdr ls)))))
(define time 0)
(define-enumerated-type color :color
@ -59,7 +84,8 @@
;;;
;;; where
;;;
;;; dag : '(#{:dfs} ...)
;;; dag : '(#{:dfs} ...) ; representation of a given
;;; directed acyclic graph)
;;; auto-leafs? : #t (by default) or #f
;;; sorted-dag : the sorted dag
;;;
@ -81,9 +107,9 @@
;; (sort pred todo-list done-list)
(sort (lambda (current position)
(< (dfs-ftime current) (dfs-ftime position)))
;;
;; the result of this should be the dag with the ftimes
;;
;;
;; the result of this should be the dag with the ftimes
;;
(let for-all-nodes ((node-name (car node-names))
(nodes-to-do (cdr node-names))
(current-dag dag))
@ -131,7 +157,8 @@
(color white) 0 #f)))
(set! current-dag (dfs-visit (cons leaf current-dag)
leaf auto-leafs?)))
(error "dfs-visit: incomplete dag!"))))
(error "dfs-visit: unresolveable adjacency: "
current-adj))))
(if (not (null? todo-adjs))
(for-all-adjs (car todo-adjs) (cdr todo-adjs)))))
(set! time (+ time 1))