206 lines
7 KiB
Scheme
206 lines
7 KiB
Scheme
;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
|
|
;;;
|
|
;;; Port Author: Andrew Whatson
|
|
;;;
|
|
;;; Original Authors: Richard Kelsey
|
|
;;;
|
|
;;; scheme48-1.9.2/ps-compiler/util/separators.scm
|
|
;;;
|
|
;;; Code to determine the separation vertices of a graph
|
|
;;;
|
|
;;; NODES is a list of nodes
|
|
;;; (TO node) returns a list of the nodes which are connected to this one
|
|
;;; (SLOT-NODE node) and (SET-SLOT! node value) are used by the algorithm to
|
|
;;; associate data with nodes (in the absence of a tables).
|
|
|
|
(define-module (ps-compiler util separators)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (prescheme scheme48)
|
|
#:export (separation-verticies))
|
|
|
|
(define (separation-vertices nodes to slot set-slot!)
|
|
(cond ((null? nodes)
|
|
(values '() '()))
|
|
((null? (cdr nodes))
|
|
(values nodes (list nodes)))
|
|
(else
|
|
(receive (separators components)
|
|
(real-separation-vertices (make-vertices nodes to slot set-slot!))
|
|
(for-each (lambda (n) (set-slot! n #f)) nodes)
|
|
(values separators components)))))
|
|
|
|
(define-record-type :vertex
|
|
(really-make-vertex data edges dfs-index)
|
|
vertex?
|
|
(data vertex-data) ;; user's data
|
|
(edges vertex-edges ;; list of edges from this vertex
|
|
set-vertex-edges!)
|
|
(dfs-index vertex-dfs-index ;; ordering from depth-first-search
|
|
set-vertex-dfs-index!)
|
|
(level vertex-level ;; value used in algorithm...
|
|
set-vertex-level!)
|
|
(parent vertex-parent ;; parent of this node in DFS tree
|
|
set-vertex-parent!))
|
|
|
|
(define (make-vertex data)
|
|
(really-make-vertex data '() 0))
|
|
|
|
(define-record-type :edge
|
|
(really-make-edge from to unused?)
|
|
edge?
|
|
(from edge-from) ;; two (unordered) vertices
|
|
(to edge-to)
|
|
(unused? edge-unused? ;; used to mark edges that have been traversed
|
|
set-edge-unused?!))
|
|
|
|
(define (make-edge from to)
|
|
(really-make-edge from to #t))
|
|
|
|
(define (other-vertex edge v)
|
|
(if (eq? v (edge-from edge))
|
|
(edge-to edge)
|
|
(edge-from edge)))
|
|
|
|
(define (maybe-add-edge from to)
|
|
(if (and (not (eq? from to))
|
|
(not (any? (lambda (e)
|
|
(or (eq? to (edge-from e))
|
|
(eq? to (edge-to e))))
|
|
(vertex-edges from))))
|
|
(let ((e (make-edge from to)))
|
|
(set-vertex-edges! from (cons e (vertex-edges from)))
|
|
(set-vertex-edges! to (cons e (vertex-edges to))))))
|
|
|
|
(define (make-vertices nodes to slot set-slot!)
|
|
(let ((vertices (map (lambda (n)
|
|
(let ((v (make-vertex n)))
|
|
(set-slot! n v)
|
|
v))
|
|
nodes)))
|
|
(for-each (lambda (n)
|
|
(for-each (lambda (n0)
|
|
(maybe-add-edge (slot n) (slot n0)))
|
|
(to n)))
|
|
nodes)
|
|
vertices))
|
|
|
|
;; The numbers are the algorithm step numbers from page 62 of Graph Algorithms,
|
|
;; Shimon Even, Computer Science Press, 1979.
|
|
;; Them Us
|
|
;; L(v) (vertex-level v)
|
|
;; k(v) (vertex-dfs-index v)
|
|
;; f(v) (vertex-parent v)
|
|
;; S stack
|
|
;; s start
|
|
|
|
(define (real-separation-vertices vertices)
|
|
(do-vertex (car vertices) 0 '() (car vertices) '() '()))
|
|
|
|
;; 2
|
|
|
|
(define (do-vertex v i stack start v-res c-res)
|
|
(let ((i (+ i 1)))
|
|
(set-vertex-level! v i)
|
|
(set-vertex-dfs-index! v i)
|
|
(find-unused-edge v i (cons v stack) start v-res c-res)))
|
|
|
|
;; 3
|
|
|
|
(define (find-unused-edge v i stack start v-res c-res)
|
|
(let ((e (first edge-unused? (vertex-edges v))))
|
|
(if e
|
|
(do-edge e v i stack start v-res c-res)
|
|
(no-unused-edge v i stack start v-res c-res))))
|
|
|
|
;; 4
|
|
|
|
(define (do-edge e v i stack start v-res c-res)
|
|
(let ((u (other-vertex e v)))
|
|
(set-edge-unused?! e #f)
|
|
(cond ((= 0 (vertex-dfs-index u))
|
|
(set-vertex-parent! u v)
|
|
(do-vertex u i stack start v-res c-res))
|
|
(else
|
|
(if (> (vertex-level v)
|
|
(vertex-dfs-index u))
|
|
(set-vertex-level! v (vertex-dfs-index u)))
|
|
(find-unused-edge v i stack start v-res c-res)))))
|
|
|
|
;; 5
|
|
|
|
(define (no-unused-edge v i stack start v-res c-res)
|
|
(let* ((parent (vertex-parent v))
|
|
(p-dfs-index (vertex-dfs-index parent)))
|
|
(cond ((= 1 p-dfs-index)
|
|
(gather-nonseparable-with-start v i stack start v-res c-res))
|
|
((< (vertex-level v) p-dfs-index)
|
|
(if (< (vertex-level v)
|
|
(vertex-level parent))
|
|
(set-vertex-level! parent (vertex-level v)))
|
|
(find-unused-edge parent i stack start v-res c-res))
|
|
(else
|
|
(gather-nonseparable v i stack start v-res c-res)))))
|
|
|
|
;; 7
|
|
|
|
(define (gather-nonseparable v i stack start v-res c-res)
|
|
(let* ((parent (vertex-parent v))
|
|
(data (vertex-data parent)))
|
|
(receive (vertices stack)
|
|
(pop-down-to stack v)
|
|
(find-unused-edge parent
|
|
i
|
|
stack
|
|
start
|
|
(if (not (memq? data v-res))
|
|
(cons data v-res)
|
|
v-res)
|
|
(cons (cons data (map vertex-data vertices)) c-res)))))
|
|
|
|
;; 9
|
|
|
|
(define (gather-nonseparable-with-start v i stack start v-res c-res)
|
|
(receive (vertices stack)
|
|
(pop-down-to stack v)
|
|
(let* ((data (vertex-data start))
|
|
(c-res (cons (cons data (map vertex-data vertices)) c-res)))
|
|
(if (not (any? edge-unused? (vertex-edges start)))
|
|
(values v-res c-res)
|
|
(find-unused-edge start
|
|
i
|
|
stack
|
|
start
|
|
(if (not (memq? data v-res))
|
|
(cons data v-res)
|
|
v-res)
|
|
c-res)))))
|
|
|
|
(define (pop-down-to stack v)
|
|
(do ((stack stack (cdr stack))
|
|
(res '() (cons (car stack) res)))
|
|
((eq? v (car stack))
|
|
(values (cons v res) (cdr stack)))))
|
|
|
|
(define (test-separation-vertices graph)
|
|
(let ((nodes (map (lambda (n)
|
|
(vector (car n) #f #f))
|
|
graph)))
|
|
(for-each (lambda (data node)
|
|
(vector-set! node 1 (map (lambda (s)
|
|
(first (lambda (v)
|
|
(eq? s (vector-ref v 0)))
|
|
nodes))
|
|
(cdr data))))
|
|
graph
|
|
nodes)
|
|
(receive (separation-vertices components)
|
|
(separation-vertices nodes
|
|
(lambda (v) (vector-ref v 1))
|
|
(lambda (v) (vector-ref v 2))
|
|
(lambda (v val) (vector-set! v 2 val)))
|
|
(values (map (lambda (v) (vector-ref v 0)) separation-vertices)
|
|
(map (lambda (l)
|
|
(map (lambda (v) (vector-ref v 0))
|
|
l))
|
|
components)))))
|