200 lines
6.3 KiB
Scheme
200 lines
6.3 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 node-name dag)
|
|
(find (lambda (candidate)
|
|
(string=? (dfs-name candidate) node-name))
|
|
dag))
|
|
|
|
;;;
|
|
;;; DEPTH FIRST SEARCH:
|
|
;;; ===================
|
|
;;;
|
|
;;; (dfs dag) ---> sorted-dag
|
|
;;; (dfs dag auto-leafs?) ---> sorted-dag
|
|
;;;
|
|
;;; where
|
|
;;;
|
|
;;; dag : '(#{:dfs} ...) ; representation of a given
|
|
;;; directed acyclic graph)
|
|
;;; auto-leafs? : #t (by default) or #f
|
|
;;; sorted-dag : the sorted dag
|
|
;;;
|
|
;;; auto-leafs?:
|
|
;;;
|
|
;;; if auto-leafs? is enabled then every adjacency which is unresolveable
|
|
;;; in the set of all node-names is assumed to point to a leaf.
|
|
;;; this leaf is then created automatically: it consists of the node-name
|
|
;;; which was given by the initiating adjencency, the empty adjacencies
|
|
;;; list, and the ignored-data-field set to #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.
|
|
;;;
|
|
(define (dfs dag . maybe-arg)
|
|
(let-optionals maybe-arg ((auto-leafs? #t))
|
|
(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 node-name current-dag)))
|
|
(cond
|
|
((eq? (dfs-color current-node) (color white))
|
|
(let ((new-dag (dfs-visit current-dag
|
|
current-node auto-leafs?)))
|
|
(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 auto-leafs?)
|
|
;; (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 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 auto-leafs?)))
|
|
(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 (really-make-dfs current-adj '()
|
|
(color white) 0 #f)))
|
|
(set! current-dag (dfs-visit (cons leaf current-dag)
|
|
leaf auto-leafs?)))
|
|
(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 node)
|
|
(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))
|
|
(begin
|
|
(display "************************************************************\n")
|
|
(display "************************************************************\n")
|
|
(newline) (newline) (newline) (newline)))))))
|