source: project/release/4/interval-digraph/interval-digraph.scm @ 20659

Last change on this file since 20659 was 20659, checked in by Ivan Raikov, 10 years ago

initial import of interval-digraph, a directed graph implementation based on adjacency intervals

File size: 25.6 KB
Line 
1;;
2;;
3;; Persistent directed graph based on adjacency intervals.
4;;
5;; Copyright 2010 Ivan Raikov and the Okinawa Institute of Science and Technology.
6;;
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20
21(module interval-digraph
22
23
24 (make-digraph digraph-union digraph-disjoint-union digraph-rename)
25
26                   
27 (import scheme chicken)
28 (require-extension rb-tree)
29 (require-library cis )
30 (import (prefix cis cis:))
31 (import (only data-structures alist-ref compose)
32         (only srfi-1 append-reverse))
33
34(define (interval-digraph:error x . rest)
35  (let ((port (open-output-string)))
36    (let loop ((objs (cons x rest)))
37      (if (null? objs)
38          (begin
39            (newline port)
40            (error 'digraph (get-output-string port)))
41          (begin (display (car objs) port)
42                 (display " " port)
43                 (loop (cdr objs)))))))
44
45(define (alist-update k v alst #!optional (eq eq?))
46  (cons (cons k v)
47        (let recur ((alst alst) (ax '()))
48          (cond ((null? alst) (reverse ax))
49                ((eq k (car (car alst))) (recur (cdr alst) ax))
50                (else (recur (cdr alst) (cons (car alst) ax)))))))
51
52(define (node-set-lookup-compare x y)
53  (if (cis:subset? x y)  0
54      (let ((xmax (cis:get-max x))
55            (xmin (cis:get-min x))
56            (ymax (cis:get-max y))
57            (ymin (cis:get-min y)))
58        (cond ((fx= ymax xmax) (fx- ymin xmin))
59              (else (fx- ymax xmax))))))
60       
61(define (node-set-insdel-compare x y)
62  (let ((xmax (cis:get-max x))
63        (xmin (cis:get-min x))
64        (ymax (cis:get-max y))
65        (ymin (cis:get-min y)))
66    (cond ((fx= ymax xmax) (fx- ymin xmin))
67          (else (fx- ymax xmax)))))
68
69(define (make-prop-tree)
70  (make-persistent-map node-set-lookup-compare 
71                       insdel-key-compare: node-set-insdel-compare))
72
73(define-record-type interval-digraph
74  (make-interval-digraph name label nodes succs preds node-props edge-props )
75  interval-digraph?
76  (name        graph-name)
77  (label       graph-label)
78  (nodes       graph-nodes)
79  (succs       graph-succs)
80  (preds       graph-preds)
81  (node-props  graph-node-props)
82  (edge-props  graph-edge-props)
83  )
84
85(define (empty-graph name label)
86  (make-interval-digraph name label cis:empty 
87                         (make-persistent-map fx-) (make-persistent-map fx-) 
88                         `((label . ,(make-prop-tree))) `((label . ,(make-prop-tree)))
89                         ))
90
91(define (interval-digraph-operations graph-instance)
92
93  (define name        (graph-name graph-instance))
94  (define label       (graph-label graph-instance))
95  (define nodes       (graph-nodes graph-instance))
96  (define succs       (graph-succs graph-instance))
97  (define preds       (graph-preds graph-instance))
98  (define node-props  (graph-node-props graph-instance))
99  (define edge-props  (graph-edge-props graph-instance))
100
101  (define (get-nodes) (cis:elements nodes))
102 
103  (define (get-nodes-with-labels) 
104    (let ((node-labels (alist-ref 'label node-props)))
105      (cis:fold-right (lambda (i ax) 
106                        (let ((label ((node-labels 'get-value) (cis:singleton i) #f)))
107                          (cons (list i label)  ax))) 
108                      '() 
109                      nodes)))
110
111
112  (define (get-edges) 
113    ((succs 'foldi)
114     (lambda (i succ-set ax) 
115       (cis:fold-left (lambda (j ax) (cons (list i j) ax)) 
116                      ax succ-set))
117     '()))
118
119
120  (define (get-edges-with-labels) 
121    ((succs 'foldi)
122     (lambda (i succ-set ax) 
123       (let* ((edge-labels (alist-ref 'label edge-props))
124              (i-labels    ((edge-labels 'get-value) (cis:singleton i) make-prop-tree)))
125         (cis:fold-left (lambda (j ax) 
126                          (let ((l ((i-labels 'get-value) (cis:singleton j) #f)))
127                            (cons (list i j l) ax))) 
128                        ax succ-set)))
129     '() ))
130
131
132  (define (order)  (cis:cardinal nodes) )
133
134  (define (size)    ((succs 'fold) (lambda (succ-set ax) (+ (cis:cardinal succ-set) ax))))
135
136  (define capacity order)
137
138  (define (add-node i #!key (label #f) )
139    (make-interval-digraph 
140     name label
141     (cis:add i nodes)
142     succs preds
143     (if label 
144         (let ((node-labels (alist-ref 'label node-props)))
145           (alist-update 'label ((node-labels 'put) (cis:singleton i) label) node-props))
146         node-props)
147     edge-props
148     ))
149
150  (define (remove-node i)
151   
152    (let ((remove-neighbor 
153           (lambda (j ax)
154             (let ((node-set ((ax 'get-value) j cis:empty))) 
155               ((ax 'put) j (cis:remove i node-set))
156               ))))
157
158      (and (cis:in? i nodes)
159           (let ((i-succ ((succs 'get-value) i cis:empty))
160                 (i-pred ((preds 'get-value) i cis:empty)))
161             
162             (let ((succs1 (cis:fold-left remove-neighbor ((succs 'delete) i (lambda _ succs)) i-pred))
163                   (preds1 (cis:fold-left remove-neighbor ((preds 'delete) i (lambda _ preds)) i-succ)))
164               
165               (make-interval-digraph name label
166                (cis:remove i nodes)
167                succs1 preds1
168                (let ((node-labels (alist-ref 'label node-props)))
169                  (alist-update 'label ((node-labels 'delete) (cis:singleton i) #f) node-props))
170                (let ((edge-labels (alist-ref 'label edge-props)))
171                  (alist-update 'label ((edge-labels 'delete) (cis:singleton i) #f) edge-props))
172                ))))
173      ))
174
175           
176
177           
178
179  (define (add-edge e #!key (label #f))
180    (cond ((and (pair? e) (pair? (cdr e)))
181
182           (let ((i (car e)) (j (cadr e)))
183
184             (and (cis:in? i nodes) (cis:in? j nodes) 
185
186                    (let* ((oi ((succs 'get-value) i cis:empty))
187                           (oj ((preds 'get-value) j cis:empty)))
188                     
189                      (let ((succs1 ((succs 'put) i (cis:add j oi)))
190                            (preds1 ((preds 'put) j (cis:add i oj))))
191                       
192                        (make-interval-digraph 
193                         name label 
194                         nodes 
195                         succs1 preds1 
196                         node-props
197                         (if label 
198                             (let* ((edge-labels  (alist-ref 'label edge-props))
199                                    (i-labels     ((edge-labels 'get-value) (cis:singleton i) make-prop-tree))
200                                    (i-labels1    ((i-labels 'put) (cis:singleton j) label))
201                                    (edge-labels1 ((edge-labels 'put) (cis:singleton i) i-labels1)))
202                               (alist-update 'label edge-labels1  edge-props))
203                             edge-props)
204                         ))))
205             ))
206          (else (interval-digraph:error 'add-edge ": invalid edge " e))))
207
208 
209
210  (define (get-succ i)           (and (cis:in? i nodes) (cis:elements ((succs 'get-value) i cis:empty))))
211
212  (define (get-succ-interval i)  (and (cis:in? i nodes) ((succs 'get-value) i cis:empty)))
213
214
215  (define (get-pred i)           (and (cis:in? i nodes) (cis:elements ((preds 'get-value) i cis:empty))))
216
217  (define (get-pred-interval i)  (and (cis:in? i nodes) ((preds 'get-value) i cis:empty)))
218
219
220  (define (out-edges i)          (and (cis:in? i nodes) 
221                                      (let ((succ-set ((succs 'get-value) i cis:empty)))
222                                        (cis:fold-left (lambda (j ax) (cons (list i j) ax)) '() 
223                                                       succ-set))))
224
225
226  (define (in-edges j)           (and (cis:in? j nodes) 
227                                      (let ((pred-set ((preds 'get-value) j cis:empty)))
228                                        (cis:fold-left (lambda (i ax) (cons (list i j) ax)) '() pred-set))))
229
230
231  (define (has-edge i j)         (and (cis:in? i nodes)
232                                      (cis:in? j ((succs 'get-value) i cis:empty))))
233                                       
234 
235  (define (has-node i)           (cis:in? i nodes) )
236
237
238  (define (has-node-interval i)  (cis:subset? i nodes) )
239
240
241  (define (edge-property p i j)  (and (cis:in? i nodes) (cis:in? j nodes) 
242                                      (let* ((prop (alist-ref p edge-props))
243                                             (i-prop (and prop ((prop 'get-value) (cis:singleton i) #f))))
244                                        (and i-prop ((i-prop 'get-value) (cis:singleton j) #f)))))
245   
246
247  (define (edge-property-set p i j v)   (and (has-edge i j)
248                                             (make-interval-digraph name label
249                                                                    nodes succs preds
250                                                                    node-props
251                                                                    (let* ((prop    (or (alist-ref p edge-props) (make-prop-tree)))
252                                                                           (i-prop  ((prop 'get-value) (cis:singleton i) make-prop-tree))
253                                                                           (i-prop1 ((i-prop 'put) (cis:singleton j) v))
254                                                                           (prop1   ((prop 'put) (cis:singleton i) i-prop1)))
255                                                                      (alist-update p prop1 edge-props))
256                                                                    )))
257
258  (define (edge-interval-property p i j)   (and (cis:cis? i) (cis:cis? j) 
259                                                (and (cis:subset? i nodes)  (cis:subset? j nodes)
260                                                     (let* ((prop (alist-ref p edge-props))
261                                                            (i-prop (and prop ((prop 'get-value) i #f))))
262                                                       (and i-prop ((i-prop 'get-value) j #f))))))
263
264  (define (edge-interval-property-set p i j v)   (and (cis:cis? i) (cis:cis? j) 
265                                                      (and (cis:subset? i nodes) (cis:subset? j nodes) 
266                                                           (make-interval-digraph name label
267                                                                                  nodes succs preds
268                                                                                  node-props
269                                                                                  (let* ((prop    (or (alist-ref p edge-props) (make-prop-tree)))
270                                                                                         (i-prop  ((prop 'get-value) i make-prop-tree))
271                                                                                         (i-prop1 ((i-prop 'put) j v))
272                                                                                         (prop1   ((prop 'put) i i-prop1)))
273                                                                                    (alist-update p prop1 edge-props))
274                                                                                  ))))
275
276  (define (node-property p i)    (and (cis:in? i nodes)
277                                      (let ((prop (alist-ref p node-props)))
278                                        (and prop ((prop 'get-value) (cis:singleton i) #f)))))
279
280                                     
281  (define (node-property-set p i v)    (and (cis:in?  i nodes) 
282                                            (make-interval-digraph name label
283                                                                   nodes succs preds
284                                                                   (let* ((prop (or (alist-ref p node-props) (make-prop-tree)))
285                                                                          (prop1 ((prop 'put) (cis:singleton i) v)))
286                                                                     (alist-update p prop1 node-props))
287                                                                   edge-props
288                                                                   )))
289
290  (define (node-interval-property p i)   (and (cis:cis? i) 
291                                              (and (cis:subset? i nodes)
292                                                   (let ((prop  (alist-ref p node-props)))
293                                                     (and prop ((prop 'get-value) i #f))))))
294
295
296  (define (node-interval-property-set p i v)   (and (cis:cis? i)
297                                                    (and (cis:subset? i nodes) 
298                                                         (make-interval-digraph name label
299                                                                                nodes
300                                                                                succs preds
301                                                                                (let* ((prop  (or (alist-ref p node-props) (make-prop-tree)))
302                                                                                       (prop1 ((prop 'put) i v)))
303                                                                                  (alist-update p prop1 node-props))
304                                                                                edge-props
305                                                                                ))))
306
307  (define (node-label i)     (node-property 'label i))
308
309  (define (node-label-set i v)   (node-property-set 'label i v))
310
311  (define (roots)                (cis:fold-left (lambda (i ax) (if (cis:empty? ((preds 'get-value) i cis:empty)) (cons i ax) ax))
312                                                nodes))
313
314
315  (define (foreach-node f)   (cis:foreach (lambda (i) (f i)) nodes))
316
317
318  (define (foreach-node-with-label f)   
319    (let ((node-labels (alist-ref 'label node-props)))
320      (cis:foreach (lambda (i) (f i ((node-labels 'get) i))) nodes)))
321
322
323  (define (foreach-edge f) ((succs 'for-each-ascending) 
324                            (lambda (i v)  (cis:foreach (lambda (j) (f i j)) v))))
325
326
327  ;; Dispatcher
328  (lambda (selector)
329      (case selector
330        ;; accessors
331        ((name)                        name)
332        ((label)                       label)
333        ((nodes)                       get-nodes)
334        ((nodes-with-labels)           get-nodes-with-labels)
335        ((node-intervals)              nodes)
336        ((edges)                       get-edges)
337        ((edges-with-labels)           get-edges-with-labels)
338        ((order)                       order)
339        ((size)                        size)
340        ((capacity)                    capacity)
341        ((out-edges)                   out-edges)
342        ((in-edges)                    in-edges)
343        ((succ)                        get-succ)
344        ((pred)                        get-pred)
345        ((succ-interval)               get-succ-interval)
346        ((pred-interval)               get-pred-interval)
347        ((has-edge)                    has-edge)
348        ((has-node)                    has-node)
349        ((has-node-interval)           has-node-interval)
350        ((node-property)               node-property)
351        ((node-interval-property)      node-interval-property)
352        ((node-label)                  node-label)
353        ((edge-property)               edge-property)
354        ((roots)                       roots)
355        ((foreach-node)                foreach-node)
356        ((foreach-node-with-label)     foreach-node-with-label)
357        ((foreach-edge)                foreach-edge)
358
359        ;; transformers
360        ((add-node)                    (compose interval-digraph-operations add-node))
361        ((remove-node)                 (compose interval-digraph-operations remove-node))
362        ((add-edge)                    (compose interval-digraph-operations add-edge))
363        ((node-label-set)              (compose interval-digraph-operations node-label-set))
364        ((node-property-set)           (compose interval-digraph-operations node-property-set))
365        ((node-interval-property-set)  (compose interval-digraph-operations node-interval-property-set))
366        ((edge-property-set)           (compose interval-digraph-operations edge-property-set))
367        ((edge-interval-property-set)  (compose interval-digraph-operations edge-interval-property-set))
368       
369        (else
370          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
371)
372
373
374
375
376(define (make-digraph name label) (interval-digraph-operations (empty-graph name label)))
377
378
379(define (merge a b compare merge-fn)
380  (let recur ((a a) (b b) (l '()))
381    (cond ((and (null? a) (null? b)) (reverse l))
382          ((null? a) (append-reverse l b))
383          ((null? b) (append-reverse l a))
384          (else
385           (let ((c (compare (car a) (car b))))
386             (cond ((negative? c)  (recur (cdr a) b (cons (car a) l)))
387                   ((zero? c)      (recur (cdr a) (cdr b) (cons (merge-fn (car a) (car b)) l)))
388                   ((positive? c)  (recur a (cdr b) (cons (car b) l))))))
389          )))
390
391
392
393(define (digraph-union a b merge-label)
394
395  (define (merge-nodes a b)
396    (merge a b
397     (lambda (x y) (fx- (car x) (car y)))
398     (lambda (x y) x)))
399
400  (define (merge-nodes-with-labels a b)
401    (merge a b
402     (lambda (x y) (fx- (car x) (car y)))
403     (lambda (x y) (list (car x) (merge-label (cadr x) (cadr y))))))
404
405  (define (merge-edges a b)
406    (merge a b
407     (lambda (x y) (let ((c (fx- (car x) (car y))))
408                     (if (zero? c) (fx- (cadr x) (cadr y)) c)))
409     (lambda (x y) x)))
410
411  (define (merge-edges-with-labels a b)
412    (merge a b
413           (lambda (x y) (let ((c (fx- (car x) (car y))))
414                           (if (zero? c) (fx- (cadr x) (cadr y)) c)))
415           (lambda (x y) (list (car x) (cadr x) (merge-label (caddr x) (caddr y))))))
416
417 
418  (let recur ((a a) (b b))
419
420    (let* (;; accessors
421           (name                  (string-append "union " (a 'name) (b 'name)))
422           (label                 (merge-label (a 'label) (b 'label)))
423           (nodes                 (lambda () (cis:elements (cis:union (a 'node-intervals) (b 'node-intervals)))))
424           (nodes-with-labels     (lambda ()
425                                    (merge-nodes-with-labels
426                                     (a 'nodes-with-labels)
427                                     (b 'nodes-with-labels))))
428           (node-intervals        (lambda () (cis:union (a 'node-intervals) (b 'node-intervals))))
429           (edges                 (lambda () (merge-edges (a 'edges) (b 'edges))))
430           (edges-with-labels     (lambda () (merge-edges-with-labels 
431                                              (a 'edges-with-labels) 
432                                              (b 'edges-with-labels))))
433           (order                  (lambda () (cis:cardinal (cis:union (a 'node-intervals) (b 'node-intervals)))))
434           (size                   (lambda () (length (edges))))
435           (capacity               order)
436           (out-edges                (lambda (i)   (merge-edges ((a 'out-edges) i) ((b 'out-edges) i))))
437           (in-edges                 (lambda (i)   (merge-edges ((a 'in-edges) i) ((b 'in-edges) i))))
438           (succ                     (lambda (i)   (cis:elements (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i)))))
439           (pred                     (lambda (i)   (cis:elements (cis:union ((a 'pred-interval) i)  ((b 'pred-interval) i)))))
440           (succ-interval            (lambda (i)   (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i))))
441           (pred-interval            (lambda (i)   (cis:union ((a 'pred-interval) i)  ((b 'pred-interval) i))))
442           (has-edge                 (lambda (i j) (or ((a 'has-edge) i j) ((b 'has-edge) i j))))
443           (has-node                 (lambda (i)   (or ((a 'has-node) i) ((b 'has-node) i))))
444           (has-node-interval        (lambda (i)   (or ((a 'has-node-interval) i) ((b 'has-node-interval) i))))
445           (edge-property            (lambda (p i j)  (or ((a 'edge-property) p i j) ((b 'edge-property) i j))))
446           (edge-interval-property   (lambda (p i j)  (or ((a 'edge-interval-property) p i j) ((b 'edge-interval-property) i j))))
447           (node-property            (lambda (p i)  (or ((a 'node-property) p i) ((b 'node-property) p i))))
448           (node-interval-property   (lambda (p i)  (or ((a 'node-interval-property) p i) ((b 'node-interval-property) p i))))
449           (node-label               (lambda (i)    (or ((a 'node-label) i) ((b 'node-label) i))))
450           (roots                    (lambda () (merge-nodes ((a 'roots)) ((b 'roots)))))
451           (foreach-node             (lambda (f) (for-each f (nodes))))
452           (foreach-node-with-label  (lambda (f) (for-each f (nodes-with-labels))))
453           (foreach-edge             (lambda (f) (for-each f (edges))))
454
455           ;; transformers
456           (add-node
457            (lambda (n #!key (label #f))
458              (recur ((a 'add-node) n label: label) ((b 'add-node) n label: label))))
459           (add-edge 
460            (lambda (e #!key (label #f))
461              (recur ((a 'add-edge) e label: label) ((b 'add-edge) e label: label))))
462           (remove-node 
463            (lambda (i) (recur ((a 'remove-node) i) ((b 'remove-node) i))))
464                         
465           (edge-interval-property-set     
466            (lambda (p i j v)  (let* ((a1 ((a 'edge-interval-property-set) p i j v))
467                                      (b1 (and (not a1) ((b 'edge-interval-property-set) p i j v))))
468                                 (cond (a1 (recur a1 b))
469                                       (b1 (recur a b1))
470                                       (else (recur a b))))))
471           (node-interval-property-set     
472            (lambda (p i v)    (let* ((a1 ((a 'node-interval-property-set) p i v))
473                                      (b1 (and (not a1) ((b 'node-interval-property-set) p i v))))
474                                 (cond (a1 (recur a1 b))
475                                       (b1 (recur a b1))
476                                       (else (recur a b))))))
477           (node-label-set         
478            (lambda (i v)      (let* ((a1 ((a 'node-label-set) i v))
479                                      (b1 (and (not a1) ((b 'node-label-set) i v))))
480                                 (cond (a1 (recur a1 b))
481                                       (b1 (recur a b1))
482                                       (else (recur a b))))))
483           (node-property-set     
484            (lambda (p i v)    (let* ((a1 ((a 'node-property-set) p i v))
485                                      (b1 (and (not a1) ((b 'node-property-set) p i v))))
486                                 (cond (a1 (recur a1 b))
487                                       (b1 (recur a b1))
488                                       (else (recur a b))))))
489           (edge-property-set     
490            (lambda (p i j v)  (let* ((a1 ((a 'edge-property-set) p i j v))
491                                      (b1 (and (not a1) ((b 'edge-property-set) p i j v))))
492                                 (cond (a1 (recur a1 b))
493                                       (b1 (recur a b1))
494                                       (else (recur a b))))))
495                                 
496           )
497
498    (lambda (selector)
499      (case selector
500        ;; accessors
501        ((name)                        name)
502        ((label)                       label)
503        ((nodes)                       nodes)
504        ((nodes-with-labels)           nodes-with-labels)
505        ((node-intervals)              node-intervals)
506        ((edges)                       edges)
507        ((edges-with-labels)           edges-with-labels)
508        ((order)                       order)
509        ((size)                        size)
510        ((capacity)                    capacity)
511        ((out-edges)                   out-edges)
512        ((in-edges)                    in-edges)
513        ((succ)                        succ)
514        ((pred)                        pred)
515        ((succ-interval)               succ-interval)
516        ((pred-interval)               pred-interval)
517        ((has-edge)                    has-edge)
518        ((has-node)                    has-node)
519        ((has-node-interval)           has-node-interval)
520        ((node-property)               node-property)
521        ((node-interval-property)      node-interval-property)
522        ((node-label)                  node-label)
523        ((edge-property)               edge-property)
524        ((roots)                       roots)
525        ((foreach-node)                foreach-node)
526        ((foreach-node-with-label)     foreach-node-with-label)
527        ((foreach-edge)                foreach-edge)
528
529        ;; transformers
530        ((add-node)                    add-node)
531        ((remove-node)                 remove-node)
532        ((add-edge)                    add-edge)
533        ((node-label-set)              node-label-set)
534        ((node-property-set)           node-property-set)
535        ((node-interval-property-set)  node-interval-property-set)
536        ((edge-property-set)           edge-property-set)
537        ((edge-interval-property-set)  edge-interval-property-set)
538       
539        (else
540          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
541   
542    )))
543                         
544;;
545;; Adds a number k to all node ids of the graph
546;;
547
548
549(define (digraph-rename k a)
550
551  (define (rename-nodes ns) (map (lambda (x) (list (fx+ k x))) ns))
552  (define (rename-nodes-with-labels ns) (map (lambda (x) (list (fx+ k (car x) (cadr x)))) ns))
553  (define (rename-edges es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)))) es))
554  (define (rename-edges-with-labels es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)) (caddr e))) es))
555
556  (let recur ((a a))
557
558    (let* (;; accessors
559           (name                     (a 'name))
560           (label                    (a 'label))
561           (nodes                    (lambda () (cis:elements (cis:shift k (a 'node-intervals) ))))
562           (nodes-with-labels        (lambda () (rename-nodes-with-labels (a 'nodes-with-labels))))
563           (node-intervals           (lambda () (cis:shift k (a 'node-intervals) )))
564           (edges                    (lambda () (rename-edges (a 'edges) )))
565           (edges-with-labels        (lambda () (rename-edges-with-labels (a 'edges-with-labels) )))
566           (order                    (lambda () (a 'order)))
567           (size                     (lambda () (a 'size)))
568           (capacity                 order)
569           (out-edges                (lambda (i)      (rename-edges ((a 'out-edges) (fx- i k)))))
570           (in-edges                 (lambda (i)      (rename-edges ((a 'in-edges) (fx- i k)))))
571           (succ                     (lambda (i)      (cis:elements (cis:shift k ((a 'succ-interval) (fx- i k) )))))
572           (pred                     (lambda (i)      (cis:elements (cis:shift k ((a 'pred-interval) (fx- i k) )))))
573           (succ-interval            (lambda (i)      (cis:shift k ((a 'succ-interval) (fx- i k) ))))
574           (pred-interval            (lambda (i)      (cis:shift k ((a 'pred-interval) (fx- i k) ))))
575           (has-edge                 (lambda (i j)    ((a 'has-edge) (fx- i k) (fx- j k))))
576           (has-node                 (lambda (i)      ((a 'has-node) (fx- i k))))
577           (has-node-interval        (lambda (i)      ((a 'has-node-interval) (cis:shift (fxneg k) i))))
578           (edge-property            (lambda (p i j)  ((a 'edge-property) p (fx- i k) (fx- j k) )))
579           (edge-interval-property   (lambda (p i j)  ((a 'edge-interval-property) p (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) )))
580           (node-property            (lambda (p i)    ((a 'node-property) p (fx- i k) )))
581           (node-interval-property   (lambda (p i)    ((a 'node-interval-property) p (cis:shift (fxneg k) i) )))
582           (node-label               (lambda (i)      ((a 'node-label) (fx- i k))))
583           (roots                    (lambda ()       (compose rename-nodes (a 'roots))))
584           (foreach-node             (lambda (f)      (for-each (lambda (i) (f (fx+ i k))) (nodes))))
585           (foreach-node-with-label  (lambda (f)      (for-each (lambda (x) (f (fx+ (car x) k) (cadr x))) (nodes-with-labels))))
586           (foreach-edge             (lambda (f)      (for-each (lambda (e) (f (list (fx+ (car e) k) (fx+ (cadr e) k)))) (edges))))
587           
588           ;; transformers
589           (add-node    (lambda (n #!key (label #f))  (recur ((a 'add-node) (fx- n k) label: label) )))
590
591           (add-edge    (lambda (e #!key (label #f))  (recur ((a 'add-edge) (list (fx- (car e) k) (fx- (cadr e) k)) label: label) )))
592
593           (remove-node (lambda (i) (recur ((a 'remove-node) (fx- i k)) )))
594
595           (edge-interval-property-set     
596            (lambda (p i j v)  (recur ((a 'edge-interval-property-set) p 
597                                       (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) v))))
598
599           (node-interval-property-set     
600            (lambda (p i v)    (recur ((a 'node-interval-property-set) p 
601                                       (cis:shift (fxneg k) i) v))))
602
603           (node-label-set         
604            (lambda (i v)      (recur ((a 'node-label-set) (fx- i k) v))))
605
606           (node-property-set     
607            (lambda (p i v)    (recur ((a 'node-property-set) p (fx- i k) v))))
608
609           (edge-property-set     
610            (lambda (p i j v)  (recur ((a 'edge-property-set) p (fx- i k) (fx- j k) v))))
611
612           )
613     
614    (lambda (selector)
615      (case selector
616        ;; accessors
617        ((name)                        name)
618        ((label)                       label)
619        ((nodes)                       nodes)
620        ((nodes-with-labels)           nodes-with-labels)
621        ((node-intervals)              node-intervals)
622        ((edges)                       edges)
623        ((edges-with-labels)           edges-with-labels)
624        ((order)                       order)
625        ((size)                        size)
626        ((capacity)                    capacity)
627        ((out-edges)                   out-edges)
628        ((in-edges)                    in-edges)
629        ((succ)                        succ)
630        ((pred)                        pred)
631        ((succ-interval)               succ-interval)
632        ((pred-interval)               pred-interval)
633        ((has-edge)                    has-edge)
634        ((has-node)                    has-node)
635        ((has-node-interval)           has-node-interval)
636        ((node-property)               node-property)
637        ((node-interval-property)      node-interval-property)
638        ((node-label)                  node-label)
639        ((edge-property)               edge-property)
640        ((roots)                       roots)
641        ((foreach-node)                foreach-node)
642        ((foreach-node-with-label)     foreach-node-with-label)
643        ((foreach-edge)                foreach-edge)
644
645        ;; transformers
646        ((add-node)                    add-node)
647        ((remove-node)                 remove-node)
648        ((add-edge)                    add-edge)
649        ((node-label-set)              node-label-set)
650        ((node-property-set)           node-property-set)
651        ((node-interval-property-set)  node-interval-property-set)
652        ((edge-property-set)           edge-property-set)
653        ((edge-interval-property-set)  edge-interval-property-set)
654       
655        (else
656          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
657   
658    )))
659
660
661(define (digraph-disjoint-union a b) (digraph-union a (digraph-rename ((a 'capacity)) b)))
662
663
664)
Note: See TracBrowser for help on using the repository browser.