source: project/graph-bfs/tags/1.4/graph-bfs.scm @ 7359

Last change on this file since 7359 was 4885, checked in by Ivan Raikov, 13 years ago

Created release 1.4

File size: 4.8 KB
Line 
1;;
2;;
3;; Breadth-first search in a graph
4;; Based on code from MLRISC
5;;
6;;
7;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
8;;
9;;
10;; This program is free software: you can redistribute it and/or
11;; modify it under the terms of the GNU General Public License as
12;; published by the Free Software Foundation, either version 3 of the
13;; License, or (at your option) any later version.
14;;
15;; This program is distributed in the hope that it will be useful, but
16;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18;; General Public License for more details.
19;;
20;; A full copy of the GPL license can be found at
21;; <http://www.gnu.org/licenses/>.
22;;
23;;
24
25(require-extension srfi-1)
26(require-extension srfi-4)
27(require-extension iset)
28
29(define-extension graph-bfs)
30
31(declare (export graph-bfs-foreach
32                 graph-bfs-fold
33                 graph-bfs-dist))
34
35(define (graph-bfs:error x . rest)
36  (let ((port (open-output-string)))
37    (let loop ((objs (cons x rest)))
38      (if (null? objs)
39          (begin
40            (newline port)
41            (error 'graph-bfs (get-output-string port)))
42          (begin (display (car objs) port)
43                 (display " " port)
44                 (loop (cdr objs)))))))
45
46(define (graph-bfs-foreach g fn fe roots)
47
48  (define (traverse visited l r)
49    (match l (()  (match r 
50                         (()       visited)
51                         ((x . _)  (traverse visited (reverse r) (list)))
52                         (else (graph-bfs:error 'bfs-foreach ": invalid node list " r))))
53           ((n . l1)  (begin
54                        (fn n)
55                        (traverse-edges visited ((g 'out-edges) n) l1 r)))
56           (else (graph-bfs:error 'bfs-foreach ": invalid node list " l))))
57
58  (define (traverse-edges visited elst l r)
59    (match elst
60           (()  (traverse visited l r))
61           (((i j . _) . es)  (if (bit-vector-ref visited j)
62                                   (traverse-edges visited es l r)
63                                   (let ((visited (bit-vector-set! visited j #t)))
64                                     (fe (car elst))
65                                     (traverse-edges visited es l (cons j r)))))
66           (else (graph-bfs:error 'bfs-foreach ": invalid edge list " elst))))
67
68  (define (traverse-roots visited ns l r)
69    (match ns
70           (()  (traverse visited l r))
71           ((n . ns1)  (if (bit-vector-ref visited n)
72                           (traverse-roots visited ns1 l r)
73                           (let ((visited (bit-vector-set! visited n #t)))
74                             (fn n)
75                             (traverse-roots visited ns1 l (cons n r)))))
76           (else (graph-bfs:error 'bfs-foreach ": invalid node list " ns))))
77   
78 
79  (traverse-roots (make-bit-vector ((g 'capacity))) roots (list) (list))
80  (void))
81
82
83(define (graph-bfs-fold g fn fe roots x y)
84
85  (define (traverse visited l r x y)
86    (match l (()  (match r 
87                         (()       (values x y))
88                         ((_ . _)  (traverse visited (reverse r) (list) x y))
89                         (else (graph-bfs:error 'bfs-foreach ": invalid node list " r))))
90           ((n . l1)  (let ((x1 (fn n x)))
91                        (traverse-edges visited ((g 'out-edges) n) l1 r x1 y)))
92           (else (graph-bfs:error 'bfs-foreach ": invalid node list " l))))
93
94  (define (traverse-edges visited elst l r x y)
95    (match elst
96           (()  (traverse visited l r x y))
97           (((i j . _) . es)  (if (bit-vector-ref visited j)
98                                   (traverse-edges visited es l r x y)
99                                   (let ((visited (bit-vector-set! visited j #t))
100                                         (y1  (fe (car elst) y)))
101                                     (traverse-edges visited es l (cons j r) x y1))))
102           (else (graph-bfs:error 'bfs-foreach ": invalid edge list " elst))))
103
104  (define (traverse-roots visited ns l r x y)
105    (match ns
106           (()  (traverse visited l r x y))
107           ((n . ns1)  (if (bit-vector-ref visited n)
108                           (traverse-roots visited ns1 l r x y)
109                           (let ((visited (bit-vector-set! visited n #t)))
110                             (traverse-roots visited ns1 l (cons n r) x y))))
111           (else (graph-bfs:error 'bfs-foreach ": invalid node list " ns))))
112   
113 
114  (traverse-roots (make-bit-vector ((g 'capacity))) roots (list) (list) x y))
115
116
117(define (graph-bfs-dist g roots)
118  (define n        ((g 'capacity)))
119  (define d        (make-s32vector n -1))
120  (define dmax     0)
121   
122  (define (traverse l r)
123    (match l (()  (match r 
124                         (()       (void))
125                         ((x . _)  (traverse (reverse r) (list)))
126                         (else (graph-bfs:error 'bfs-dist ": invalid node list " r))))
127           ((n . l1)  (begin
128                        (traverse-edges ((g 'out-edges) n) l1 r)))
129           (else (graph-bfs:error 'bfs-dist ": invalid node list " l))))
130
131
132  (define (traverse-edges elst l r)
133    (match elst
134           (()  (traverse l r))
135           (((i j . _) . es)  (let ((di (s32vector-ref d i)))
136                                (set! dmax (max dmax (fx+ 1 di)))
137                                (s32vector-set! d j (fx+ 1 di))
138                                (traverse-edges es l (cons j r))))
139           (else (graph-bfs:error 'bfs-dist ": invalid edge list " elst))))
140
141  (define (traverse-roots ns l r)
142    (match ns
143           (()  (traverse l r))
144           ((n . ns1)  (if (fx>= (s32vector-ref d n) 0)
145                           (traverse-roots ns1 l r)
146                           (begin (s32vector-set! d n 0)
147                                  (traverse-roots ns1 l (cons n r)))))
148           (else (graph-bfs:error 'bfs-dist ": invalid node list " ns))))
149   
150
151  (traverse-roots roots (list) (list))
152  (values d dmax))
Note: See TracBrowser for help on using the repository browser.