dfs.scm: depth-first-search/sort algorithm, work in progress...\n to-rule-set.scm: calls dfs, work in progress...

dfs.scm

@@ -0,0 +1,100 @@
+(define-enumerated-type color :color
+  is-color?
+  the-color
+  color-name
+  color-index
+  (white grey black))
+
+(define-record-type :dfs
+  (really-make-dfs node adjacencies color predec dtime ftime ignored-data)
+  is-dfs?
+  (node dfs-node)
+  (adjacencies dfs-adjacencies)
+  ;; color (white by default)
+  (color dfs-color)
+  ;; predecessor (is #f by default)
+  (predec dfs-predec)
+  ;; discovery-time
+  (dtime dfs-dtime)
+  ;; finishing-time
+  (ftime dfs-ftime)
+  ;; thie is for all node specific information 
+  ;; and is ignore by the dfs algorithm
+  ;; put in there what you like
+  (ignored-data dfs-ignored-data))
+
+(define (make-dfs node adjacencies ignored-data)
+  (really-make-dfs node adjacencies (color white) 0 0 #f ignored-data))
+
+(define (dfs->list dfs)
+  (list (dfs-node dfs) (dfs-adjacencies dfs) (dfs-ignored-data dfs)))
+
+(define (dfs-timer ch)
+  (spawn
+    (lambda ()
+      (let timer-loop ((current-time 0))
+	(cml-sync-ch/receive ch)
+	(cml-sync-ch/send ch current-time)
+	(timer-loop (+ current-time 1))))))
+
+(define (dfs-time ch)
+  (cml-sync-ch/send ch 'get-time)
+  (cml-sync-ch/receive ch))
+
+(define (dfs-lookup-adjs dag adj)
+  (let ((maybe-rc ))
+    (if maybe-rc maybe-rc
+
+(define (dfs-visit dag node time-ch)
+  (set! (dfs-color node) (color grey))
+  (set! (dfs-dtime node) (dfs-time time-ch))
+  (for-each (lambda (adj)
+	      (cond 
+	       ((eq? (dfs-color adj) (color white))
+		(begin 
+		  (set! (dfs-predecessor adj) node)
+		  (dfs-visit adj time-ch)))
+	       ;; 
+	       ;; ((eq? (dfs-color adj) (color black))
+	       ;; "already been here")
+	       ;; 
+	       ((eq? (dfs-color adj) (color grey))
+		(error "dfs-visit: cycle detected!"))))
+	    ;; this should be the list of all adjacency-nodes
+	    ;; this is done by map over all adjacencies
+	    ;; lookup each adj in dag, check if its node-name is adj
+	    (map (lambda (adj) 
+		   (find (lambda (candidate) 
+			   (eq? (dfs-node candidate) adj))
+			 dag))
+		 (dfs-adjs node)))
+  (set! (dfs-color node) (color black))
+  (set! (dfs-ftime node) (dfs-time time-ch)))
+
+;;; this is the depth first search algorithm
+;;; dag is a list of nodes of record-type dfs 
+(define (dfs dag)
+  (let* ((time-ch (cml-sync-ch/make-channel))
+	 (start-timer (dfs-timer time-ch)))
+    (if (not (null? dag))
+	(begin
+	  (let visit-each-node ((current-node (car dag))
+				(nodes-to-do (cdr dag)))
+	    (if (eq? (dfs-color current-node) (color white))
+		(dfs-visit dag current-node time-ch))
+	    (if (not (null? nodes-to-do))
+		(visit-each-node (car nodes-to-do) (cdr nodes-to-do))))
+	  ;; now sort field (dfs-ftime node) in descendent order
+	  ...
+	  ))))
+
+(define (dfs-sort-insert pred item queue)
+  (cond 
+   ((null? queue) (cons item))
+   ((not (pred item (car queue))) (cons item queue))
+   (else (dfs-sort-insert item (cdr queue)))))
+
+(define (dfs-sort pred todo done)
+  (if (null? todo)
+      done
+      (dfs-sort pred (cdr todo) (dfs-sort-insert pred (car todo) done))))

to-rule-set.scm

@@ -1,71 +1,45 @@
-(define-record-type :rc-set
+(define (rcs->dag rcs)
-  (make-rc-set rule-candidates fname-rule-table rule-set)
+  (map (lambda (rc)
-  is-rc-set?
+	 (make-dfs (car rc) (cadr rc) (caddr rc) (cadddr rc)))
-  (rule-candidates rc-set-rule-candidates)
+       rcs))
-  (fname-rule-table rc-set-fname-rule-table)
-  (rule-set rc-set-rule-set))
 
-(define-enumerated-type color :color
+(define (dag->rcs dag)
-  is-color?
+  (map (lambda (node)
-  the-color
+	 (let* ((ls (dfs->list node))
-  color-name
+		(target (car ls))
-  color-index
+		(prereqs (cadr ls))
-  (white grey black))
+		(wants-build? (caddr ls))
+		(build-func (cdddr ls)))
+	   (list target prereqs wants-build? build-func)))
+       dag))
 
-(define-record-type :dfs-data
+(define (lookup-rc rcs rc)
-  (make-dfs-data rc color discovery-time finishing-time predecessor)
+  (let ((maybe-rc (find (lambda (current) 
-  is-dfs-data?
+			  (eq? (car rc) (car current))) 
-  (rc dfs-data-rc)
+			rcs)))
-  (color dfs-data-color)
+    (if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
-  (discovery-time dfs-data-discovery-time)
-  (finishing-time dfs-data-finishing-time)
-  (predecessor dfs-data-predecessor))
 
-(define (dfs-timer ch)
+(define (rcs->rules rcs)
-  (spawn
+  (let ((sorted-rcs (dag->rcs (dfs (rcs->dag rcs)))))
-    (lambda ()
+    (map (lambda (rc) 
-      (let timer-loop ((current-time 0))
+	   (let* ((target (car rc))
-	(cml-sync-ch/receive ch)
+		  (prereqs (cadr rc))
-	(cml-sync-ch/send ch current-time)
+		  (wants-build? (caddr rc))
-	(timer-loop (+ current-time 1))))))
+		  (build-func (cdddr rc))
+		  (prereq-rcs (map (lambda (p) 
+				     (lookup-rc sorted-rcs p))
+				   prereqs))
+		  (rule (make-rule prereq-rcs wants-build? build-func)))
+	     (cons target rule)))
+	 rcs)))
 
-(define (dfs-time ch)
+(define (rules->rule-set rules)
-  (cml-sync-ch/send ch 'get-time)
+  (let for-each-rule ((current-rule (if (null? rules) '() (car rules)))
-  (cml-sync-ch/receive ch))
+		      (rules-to-do (if (null? rules) '() (cdr rules)))
+		      (rule-set (make-empty-rule-set)))
+    (if (not (null? rules-to-do))
+	(for-each-rule (car rules-to-do) 
+		       (cdr rules-to-do)
+		       (rule-set-add current-rule rule-set)))
+    rule-set))
 
-(define (dfs-lookup-prereq rc-set prereq)
-  (let ((maybe-rc (assoc prereq (rc-set-rule-candidates rc-set))))
-    (if maybe-rc (car 
-
-(define (dfs-visit node time-ch)
-  (set! (dfs-data-color node) (color grey))
-  (set! (dfs-data-discovery-time node) (dfs-time time-ch))
-  (for-each (lambda (prereq)
-	      (if (eq? (dfs-data-color prereq) (color white))
-		  (begin 
-		    (set! (dfs-data-predecessor prereq) node)
-		    (dfs-visit prereq time))))
-	    ;; rule-candidates:
-	    ;; ((target . (prereqs wants-build? build-func)) ...)
-	    ;; lookup the node for prereq
-	    (map dfs-lookup-prereq
-		 (cadr (rc-set-rule-candidates (dfs-data-rc node))))
-  (set! (dfs-data-color node) (color black))
-  (set! (dfs-data-discovery-time node) (dfs-time time-ch))
-
-;;; this is the depth first search algorithm
-(define (dfs rc-set)
-  (let* ((rule-candidates (rc-set-rule-candidates rc-set))
-	 (fname-rule-table (rc-set-fname-rule-table rc-set))
-	 (rule-set (rc-set-rule-set rc-set))
-	 (rc-dfs-data (map (lambda (rc) (make-dfs-data rc (color white) 0 0 #f))
-			   rule-candidates))
-	 (time 0))
-
-    (
-
-    (if (not (null? rc-dfs-data))
-	(let visit-each-rc ((current-rc (car rc-dfs-data))
-			    (to-visit-rcs (cdr rc-dfs-data)))
-	  (if (eq? (color-name (dfs-data-color dfs-data)) (color white))
-	      (begin