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 time 0)
(define-enumerated-type color :color (define-enumerated-type color :color
@ -59,7 +84,8 @@
;;; ;;;
;;; where ;;; where
;;; ;;;
;;; dag : '(#{:dfs} ...) ;;; dag : '(#{:dfs} ...) ; representation of a given
;;; directed acyclic graph)
;;; auto-leafs? : #t (by default) or #f ;;; auto-leafs? : #t (by default) or #f
;;; sorted-dag : the sorted dag ;;; sorted-dag : the sorted dag
;;; ;;;
@ -81,9 +107,9 @@
;; (sort pred todo-list done-list) ;; (sort pred todo-list done-list)
(sort (lambda (current position) (sort (lambda (current position)
(< (dfs-ftime current) (dfs-ftime 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)) (let for-all-nodes ((node-name (car node-names))
(nodes-to-do (cdr node-names)) (nodes-to-do (cdr node-names))
(current-dag dag)) (current-dag dag))
@ -131,7 +157,8 @@
(color white) 0 #f))) (color white) 0 #f)))
(set! current-dag (dfs-visit (cons leaf current-dag) (set! current-dag (dfs-visit (cons leaf current-dag)
leaf auto-leafs?))) leaf auto-leafs?)))
(error "dfs-visit: incomplete dag!")))) (error "dfs-visit: unresolveable adjacency: "
current-adj))))
(if (not (null? todo-adjs)) (if (not (null? todo-adjs))
(for-all-adjs (car todo-adjs) (cdr todo-adjs))))) (for-all-adjs (car todo-adjs) (cdr todo-adjs)))))
(set! time (+ time 1)) (set! time (+ time 1))