214 lines
7.1 KiB
Scheme
214 lines
7.1 KiB
Scheme
;;;
|
|
;;; 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)))))))
|