scsh-make/dfs.scm

;;; 
;;; 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-enumerated-type color :color
  is-color?
  the-colors
  color-name
  color-index
  (white grey black))

;;; 
;;; DFS:
;;; ====
;;; 
;;; (make-dfs node-name adjacencies ignored-data) ---> #{:dfs}
;;; 
;;; node-name    : "this is a node name"
;;; adjacencies  : (list "another node name" "no node name")
;;; ignored-data : "anything you need in each node, eg. a long list..."
;;; 
;;; (dfs->list node) ---> '(node-name adjacencies ignored-data)
;;; 
;;; node         : #{:dfs}
;;; 
;;; (dfs-name node) ---> node-name
;;; (dfs-adjacencies node) ---> adjacencies
;;; (dfs-color node) ---> #{:color}
;;; (dfs-ftime node) ---> finishing-time
;;; (dfs-ignored node) ---> ignored-data
;;; 
(define-record-type :dfs
  (really-make-dfs name adjacencies color ftime ignored)
  is-dfs?
  (name dfs-name)
  (adjacencies dfs-adjacencies)
  ;; color (white by default)
  (color dfs-color)
  ;; finishing-time
  (ftime dfs-ftime)
  ;; put in there what you like
  (ignored dfs-ignored))

(define (make-dfs node-name adjacencies ignored-data)
  (really-make-dfs node-name adjacencies (color white) 0 ignored-data))

(define (dfs->list dfs-node)
  (list (dfs-name dfs-node) (dfs-adjacencies dfs-node) (dfs-ignored dfs-node)))

(define (resolve-adj pred adj dag)
  (find (lambda (candidate) 
	  (pred (dfs-name candidate) adj))
	dag))

(define (replace-node dag old new)
  (let ((new-dag (delete old dag)))
    (cons new new-dag)))

(define (paint-node node color)
  (let ((name (dfs-name node))
	(adjs (dfs-adjacencies node))
	(time (dfs-ftime node))
	(ignored (dfs-ignored node)))
    (really-make-dfs name adjs color time ignored)))

(define (set-ftime node ftime)
  (let ((name (dfs-name node))
	(adjs (dfs-adjacencies node))
	(color (dfs-color node))
	(ignored (dfs-ignored node)))
    (really-make-dfs name adjs color ftime ignored)))

;;; 
;;; DEPTH FIRST SEARCH:
;;; ===================
;;; 
;;; (dfs dag) ---> sorted-dag
;;; (dfs dag pred auto-leafs? create-leaf) ---> sorted-dag
;;; 
;;;             where 
;;; 
;;; dag           : '(#{:dfs} ...) ; representation of a given
;;;                                  directed acyclic graph) 
;;; pred          : (pred adj-id node-id) ---> #t (if adj-identifier
;;;                 and node-identifier are equal) or #f
;;; 
;;; auto-leafs?   : #t (by default) or #f
;;; 		    if auto-leafs? is set to #f then it is an error
;;; 		    that an adjacency is unresolveable in the list of
;;; 		    all node-names.  if auto-leafs? is enabled then
;;; 		    every adjacency which is unresolveable in the list
;;; 		    of all node-names is assumed to point to a leaf.
;;; 		    this leaf is then created automatically by
;;; 		    executing the function create-leaf. 
;;; 
;;; create-leaf   : (create-leaf unresolved-adjacency-identifier) ---> #{:dfs}
;;; 		    create-leaf is a function which is called with the
;;; 		    unresolved adjacency identifier. By default, this
;;; 		    argument is function returning a leaf named with
;;; 		    the unresolved adjacency identifier, with no
;;; 		    adjacencies, and ignored-data set to #f. This
;;;                 leaf, created by create-leaf, doesn't really have
;;;                 to be a leaf; it can be a node as well. Maybe this
;;;                 introduces new cyclic dependency problems; not sure.
;;; 
;;; sorted-dag    : the sorted dag
;;; 
(define (dfs dag . maybe-args)
  (let-optionals maybe-args 
      ((pred string=?)
       (auto-leafs? #t)
       (create-leaf (lambda (unresolved-adj) 
		      (make-dfs unresolved-adj '() #f))))
    (let ((ftime<? (lambda (cur pos)
		     (< (dfs-ftime cur) (dfs-ftime pos)))))
      (if (not (null? dag))
	  (sort ftime<? 
		(visit-all-nodes dag pred auto-leafs? create-leaf)
		(list))
	  dag))))

(define (visit-all-nodes start-dag pred auto-leafs? create-leaf)
  (let for-each-node ((node (car start-dag))
		      (todo (cdr start-dag))
		      (dag start-dag)
		      (time 0))
    (cond 
     ((eq? (dfs-color node) (color white))
      (let* ((result (visit dag node time pred auto-leafs? create-leaf))
	     (new-dag (car result))
	     (new-time (cdr result)))
	(if (not (null? todo))
	    (for-each-node (car todo) (cdr todo) new-dag new-time)
	    new-dag)))
     ((eq? (dfs-color node) (color black))
      (if (not (null? todo))
	  (for-each-node (car todo) (cdr todo) dag time)
	  dag))
     (else (error "visit-all-nodes: no match")))))

(define (finish-visit dag node time)
  (let* ((new-time (+ 1 time))
	 (done-node (set-ftime (paint-node node (color black))
			       new-time))
	 (done-dag (replace-node dag node done-node)))
    (cons done-dag new-time)))

(define (visit old-dag old-node time pred auto-leafs? create-leaf)
  (let* ((node (paint-node old-node (color grey)))
	 (adjs (dfs-adjacencies node))
	 (dag (replace-node old-dag old-node node)))
    (if (not (null? adjs))
	(visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
	(finish-visit dag node time))))

(define (visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
  (let for-each-adj ((cur-adj (car adjs))
		     (todo (cdr adjs))
		     (cur-dag dag)
		     (cur-time time))
    (let* ((res (follow-adj cur-dag node cur-adj cur-time 
			    pred auto-leafs? create-leaf))
	   (new-dag (car res))
	   (new-time (cdr res)))
      (if (not (null? todo))
	  (for-each-adj (car todo) (cdr todo) new-dag new-time)
	  (finish-visit new-dag node new-time)))))

(define (follow-adj dag node adj time pred auto-leafs? create-leaf)
  (let ((maybe-node (resolve-adj pred adj dag)))
    (if maybe-node
	(cond 
	 ((eq? (dfs-color maybe-node) (color white))
	  (visit dag maybe-node time pred auto-leafs? create-leaf))
	 ((eq? (dfs-color maybe-node) (color grey))
	  (error "follow-adj, cycle detected: " (dfs-name node)))
	 ((eq? (dfs-color maybe-node) (color black))
	  (cons dag time))
	 (else (error "follow-adj: no match")))
	(if auto-leafs? 
	    (let* ((leaf (create-leaf adj))
		   (new-dag (cons leaf dag)))
	      (visit new-dag leaf time pred auto-leafs? create-leaf))
	    (error "follow-adj: unresolveable adjacency: " adj)))))

(define (dfs-dag-show dag . maybe-arg)
  (let-optionals maybe-arg ((node (make-dfs "show dag" '() #f)))
    (newline) (newline) (newline) (newline)
    (display "************************************************************\n")
    (display (dfs-name node)) (newline)
    (display "************************************************************\n")
    (let ((dfs-node-show (lambda (node)
			   (newline)
			   (display "~dfs-name:        ")
			   (display (dfs-name node))
			   (newline)
			   (display "~dfs-adjacencies: ")
			   (display (dfs-adjacencies node))
			   (newline)
			   (display "~dfs-color:       ")
			   (display (dfs-color node))
			   (newline)
			   (display "~dfs-ftime:       ")
			   (display (dfs-ftime node))
			   (newline)
			   (display "~dfs-ignored:     ")
			   (display (dfs-ignored node))
			   (newline))))
      (if (not (null? dag))
	  (let visit-each-node ((current-node (car dag))
				(nodes-to-do (cdr dag)))
	    (dfs-node-show current-node)
	    (if (not (null? nodes-to-do))
		(visit-each-node (car nodes-to-do) (cdr nodes-to-do))
		(newline)))))))