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 time 0)

(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 (dfs-lookup-node pred node-name dag)
  (find (lambda (candidate) 
	  (pred (dfs-name candidate) node-name))
	dag))

;;; 
;;; 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-id) 
					    ;; (display "unresolved adjecency: ")
					    ;; (display unresolved-adj-id)
					    ;; (newline)
					    (make-dfs unresolved-adj-id '() #f))))
    (set! time 0)
    (let ((node-names (map dfs-name dag)))
      (if (not (null? node-names))
	  ;; (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
		;; 
		(let for-all-nodes ((node-name (car node-names))
				    (nodes-to-do (cdr node-names))
				    (current-dag dag))
		  (let ((current-node (dfs-lookup-node pred node-name current-dag)))
		    (cond 
		     ((eq? (dfs-color current-node) (color white))
		      (let ((new-dag (dfs-visit current-dag current-node 
						pred auto-leafs? create-leaf)))
			(if (not (null? nodes-to-do))
			    (for-all-nodes (car nodes-to-do) 
					   (cdr nodes-to-do) 
					   new-dag)
			    new-dag)))
		     (else (if (not (null? nodes-to-do))
			       (for-all-nodes (car nodes-to-do) 
					      (cdr nodes-to-do) 
					      current-dag)
			       current-dag)))))
		'())
	  node-names))))

(define (dfs-visit dag node pred auto-leafs? create-leaf)
  ;;  (dfs-dag-show dag node)
  (let ((name (dfs-name node))
	(adjs (dfs-adjacencies node))
	(ignored (dfs-ignored node)))
    (let* ((current-node (really-make-dfs name adjs (color grey) 
					  (dfs-ftime node) ignored))
	   (current-dag (cons current-node (delete node dag))))
      (if (not (null? adjs))
	  (let for-all-adjs ((current-adj (car adjs))
			     (todo-adjs (cdr adjs)))
	    (let ((maybe-node (dfs-lookup-node pred current-adj current-dag)))
	      (if maybe-node
		  (begin 
		    (if (eq? (dfs-color maybe-node) (color white))
			(let ((next-dag (dfs-visit current-dag maybe-node 
						   pred auto-leafs? create-leaf)))
			  (set! current-dag next-dag))
			(if (eq? (dfs-color maybe-node) (color grey))
			    (error "dfs-visit: cycle detected; node-name: "
				   (dfs-name node)))))
		  (if auto-leafs? 
		      (let ((leaf (create-leaf current-adj)))
			(set! current-dag (dfs-visit (cons leaf current-dag) leaf 
						     pred auto-leafs? create-leaf)))
		      (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))
      (cons (really-make-dfs name adjs (color black) time ignored)
	    (delete current-node current-dag)))))

(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)))))))