source: project/digraph/tags/1.7a/digraph.scm @ 7359

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

Bug fixes in set-out-edges! and set-in-edges! [thanks to Andreas Scholta].

File size: 7.8 KB
Line 
1;;
2;;
3;; Directed graph in adjacency list format.
4;; Based on code from MLRISC
5;;
6;; Version $Revision$
7;;
8;;
9;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
10;;
11;;
12;; This program is free software: you can redistribute it and/or
13;; modify it under the terms of the GNU General Public License as
14;; published by the Free Software Foundation, either version 3 of the
15;; License, or (at your option) any later version.
16;;
17;; This program is distributed in the hope that it will be useful, but
18;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20;; General Public License for more details.
21;;
22;; A full copy of the GPL license can be found at
23;; <http://www.gnu.org/licenses/>.
24
25(require-extension srfi-1)
26(require-extension dyn-vector)
27
28(define-extension digraph)
29
30(declare (export make-digraph))
31
32(define (digraph:error x . rest)
33  (let ((port (open-output-string)))
34    (let loop ((objs (cons x rest)))
35      (if (null? objs)
36          (begin
37            (newline port)
38            (error 'digraph (get-output-string port)))
39          (begin (display (car objs) port)
40                 (display " " port)
41                 (loop (cdr objs)))))))
42
43(define (make-digraph name info . rest)
44 (let-optionals  rest ((node-list (list)) (succ-list (list)) (pred-list (list)))
45  (define nodes    (list->dynvector node-list 'none))
46  (define succ     (list->dynvector succ-list (list)))
47  (define pred     (list->dynvector pred-list (list)))
48
49  (define node-count     0)
50  (define edge-count     0)
51  (define entries        (list))
52  (define exits          (list))
53  (define new-nodes      (list))
54  (define garbage-nodes  (list))
55
56  (define (new-id!) 
57    (match new-nodes
58           (()      (dynvector-length nodes))
59           ((h . t) (begin
60                      (set! new-nodes t)
61                      h))
62           (else (digraph:error 'new-id ": invalid new-nodes " new-nodes))))
63 
64  (define (garbage-collect!) =
65    (set! new-nodes (append new-nodes garbage-nodes))
66    (set! garbage-nodes (list)))
67
68  (define (get-nodes)
69    (dynvector-fold 
70     (lambda (i st v) (case v ((none) st) (else (cons (list i v) st)))) 
71     (list) nodes))
72
73  (define (get-edges)
74    (concatenate 
75     (dynvector-fold 
76      (lambda (i st v) 
77        (match v (() st) (else (cons v st)))) (list) succ)))
78
79  (define (order)  node-count)
80
81  (define (size)   edge-count)
82
83  (define (capacity) (dynvector-length nodes))
84
85  (define (add-node! i info)
86    (case (dynvector-ref nodes i)
87      ((none) (set! node-count (fx+ 1 node-count))))
88    (dynvector-set! nodes i info))
89
90  (define (add-edge! e)
91    (match e
92           ((i j info)   
93            (let ((oi (dynvector-ref succ i))
94                  (oj (dynvector-ref pred j)))
95              (dynvector-set! succ i (cons e oi))
96              (dynvector-set! pred j (cons e oj))
97              (set! edge-count (fx+ 1 edge-count))))
98           (else (digraph:error 'new-id ": invalid edge " e))))
99
100  (define (set-out-edges! i edges)
101    (define (remove-pred elst j ax)
102      (match elst 
103             (() (dynvector-set! pred j ax))
104             (((i1 _ _) . es)  (let ((e (car elst)))
105                                 (remove-pred es j (if (fx= i1 i) ax (cons e ax)))))
106             (else   (digraph:error 'remove-pred ": invalid edge list " elst))))
107
108    (define (remove-edge e)
109      (match e 
110             ((i1 j _)  (begin
111                            (if (not (fx= i i1)) (digraph:error 'set-out-edges))
112                            (remove-pred (dynvector-ref pred j) j (list))))
113             (else (digraph:error 'remove-edge ": invalid edge " e))))
114
115    (define (add-pred e)
116      (match e 
117             ((_ j _)  (dynvector-set! pred j (cons e (dynvector-ref pred j))))
118             (else (digraph:error 'add-pred ": invalid edge " e))))
119   
120    (let ((old-edges (dynvector-ref succ i)))
121      (for-each remove-edge old-edges)
122      (dynvector-set! succ i edges)
123      (for-each add-pred edges)
124      (set! edge-count (fx- (fx+ edge-count (length edges)) (length old-edges)))))
125
126
127  (define (set-in-edges! j edges)
128    (define (remove-succ elst i ax)
129      (match elst 
130             (() (dynvector-set! succ i ax))
131             (((_ j1 _) . es)  (let ((e (car elst)))
132                                 (remove-succ es i (if (fx= j1 j) ax (cons e ax)))))
133             (else   (digraph:error 'remove-succ ": invalid edge list " elst))))
134
135    (define (remove-edge e)
136      (match e 
137             ((i j1 _)  (begin
138                            (if (not (fx= j j1)) (digraph:error 'set-in-edges))
139                            (remove-succ (dynvector-ref succ i) i (list))))
140             (else (digraph:error 'remove-edge ": invalid edge " e))))
141
142    (define (add-succ e)
143      (match e 
144             ((i _ _)  (dynvector-set! succ i (cons e (dynvector-ref succ i))))
145             (else (digraph:error 'add-succ ": invalid edge " e))))
146
147    (let ((old-edges (dynvector-ref pred j)))
148      (for-each remove-edge old-edges)
149      (dynvector-set! pred j edges)
150      (for-each add-succ edges)
151      (set! edge-count (fx- (fx+ edge-count (length edges)) (length old-edges)))))
152
153  (define (remove-node! i)
154    (case (dynvector-ref nodes i)
155      ((none))
156      (else    (begin
157                 (set-out-edges! i (list))
158                 (set-in-edges! i  (list))
159                 (dynvector-set! nodes i 'none)
160                 (set! node-count (fx- node-count 1))
161                 (set! garbage-nodes (cons i garbage-nodes))
162                 (void)))))
163 
164  (define (remove-nodes! ns) (for-each remove-node! ns))
165  (define (set-entries! ns)  (set! entries ns))
166  (define (set-exits! ns)    (set! exits ns))
167  (define (get-entries)      entries)
168  (define (get-exits)        exits)
169  (define (out-edges n)      (dynvector-ref succ n))
170  (define (in-edges n)       (dynvector-ref pred n))
171
172  (define (get-succ n)       (map (lambda (x) (list-ref x 1)) (dynvector-ref succ n)))
173  (define (get-pred n)       (map (lambda (x) (list-ref x 0)) (dynvector-ref pred n)))
174
175  (define (has-edge i j)     (any (lambda (e) 
176                                    (match e ((_ j1 _) (fx= j j1))
177                                           (else (digraph:error 'has-edge ": invalid edge " e))))
178                                  (dynvector-ref succ i)))
179 
180  (define (has-node n)       (case (dynvector-ref nodes n)
181                               ((none)  #f)
182                               (else #t)))
183
184  (define (node-info n)      (let ((info (dynvector-ref nodes n)))
185                               (case info
186                                 ((none)  #f)
187                                 (else    info))))
188
189  (define (foreach-node f)   (dynvector-for-each (lambda (i x) (case x  ((none)) (else  (f i x)))) nodes))
190  (define (foreach-edge f)   (dynvector-for-each f succ))
191
192 
193  ;; Dispatcher
194  (lambda (selector)
195      (case selector
196        ((name)              name)
197        ((graph-info)        info)
198        ((new-id!)           new-id!)
199        ((add-node!)         add-node!)
200        ((add-edge!)         add-edge!)
201        ((remove-node!)      remove-node!)
202        ((set-in-edges!)     set-in-edges!)
203        ((set-out-edges!)    set-out-edges!)
204        ((set-entries!)      set-entries!)
205        ((set-exits!)        set-exits!)
206        ((garbage-collect!)  garbage-collect!)
207        ((nodes)             get-nodes)
208        ((edges)             get-edges)
209        ((order)             order)
210        ((size)              size)
211        ((capacity)          capacity)
212        ((out-edges)         out-edges)
213        ((in-edges)          in-edges)
214        ((succ)              get-succ)
215        ((pred)              get-pred)
216        ((has-edge)          has-edge)
217        ((has-node)          has-node)
218        ((node-info)         node-info)
219        ((entries)           get-entries)
220        ((exits)             get-exits)
221        ((entry-edges)       (lambda (x) (list)))
222        ((exit-edges)        (lambda (x) (list)))
223        ((foreach-node)      foreach-node)
224        ((foreach-edge)      foreach-edge)
225        ((roots)             (lambda ()
226                               (filter-map (lambda (n)
227                                             (if (null?
228                                                  ;; check only edges from other nodes
229                                                  (remove (o (cut fx= <> (car n)) car)
230                                                          (in-edges (car n))))
231                                                 (car n)
232                                                 #f))
233                                           (get-nodes))))
234        ((debug)             (list (cons nodes (dynvector->list nodes))
235                                   (cons succ (dynvector->list succ))
236                                   (cons pred (dynvector->list pred))))
237        (else
238          (digraph:error 'selector ": unknown message " selector " sent to a graph"))))))
Note: See TracBrowser for help on using the repository browser.