dfs.scm: depth-first-search/sort algorithm, work in progress...\n to-rule-set.scm: calls dfs, work in progress...
This commit is contained in:
jottbee
parent
afb60fbb74
commit
5b462916b1
|
|
@ -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))))
|
||||
106
to-rule-set.scm
106
to-rule-set.scm
|
|
@ -1,71 +1,45 @@
|
|||
(define-record-type :rc-set
|
||||
(make-rc-set rule-candidates fname-rule-table rule-set)
|
||||
is-rc-set?
|
||||
(rule-candidates rc-set-rule-candidates)
|
||||
(fname-rule-table rc-set-fname-rule-table)
|
||||
(rule-set rc-set-rule-set))
|
||||
(define (rcs->dag rcs)
|
||||
(map (lambda (rc)
|
||||
(make-dfs (car rc) (cadr rc) (caddr rc) (cadddr rc)))
|
||||
rcs))
|
||||
|
||||
(define-enumerated-type color :color
|
||||
is-color?
|
||||
the-color
|
||||
color-name
|
||||
color-index
|
||||
(white grey black))
|
||||
(define (dag->rcs dag)
|
||||
(map (lambda (node)
|
||||
(let* ((ls (dfs->list node))
|
||||
(target (car ls))
|
||||
(prereqs (cadr ls))
|
||||
(wants-build? (caddr ls))
|
||||
(build-func (cdddr ls)))
|
||||
(list target prereqs wants-build? build-func)))
|
||||
dag))
|
||||
|
||||
(define-record-type :dfs-data
|
||||
(make-dfs-data rc color discovery-time finishing-time predecessor)
|
||||
is-dfs-data?
|
||||
(rc dfs-data-rc)
|
||||
(color dfs-data-color)
|
||||
(discovery-time dfs-data-discovery-time)
|
||||
(finishing-time dfs-data-finishing-time)
|
||||
(predecessor dfs-data-predecessor))
|
||||
(define (lookup-rc rcs rc)
|
||||
(let ((maybe-rc (find (lambda (current)
|
||||
(eq? (car rc) (car current)))
|
||||
rcs)))
|
||||
(if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
|
||||
|
||||
(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 (rcs->rules rcs)
|
||||
(let ((sorted-rcs (dag->rcs (dfs (rcs->dag rcs)))))
|
||||
(map (lambda (rc)
|
||||
(let* ((target (car rc))
|
||||
(prereqs (cadr rc))
|
||||
(wants-build? (caddr rc))
|
||||
(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)
|
||||
(cml-sync-ch/send ch 'get-time)
|
||||
(cml-sync-ch/receive ch))
|
||||
(define (rules->rule-set rules)
|
||||
(let for-each-rule ((current-rule (if (null? rules) '() (car rules)))
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in New Issue