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

Last change on this file since 25487 was 25487, checked in by Ivan Raikov, 9 years ago

interval-digraph: bug fixes and additions to edge iterator interfaces

File size: 27.8 KB
Line 
1;;
2;;
3;; Persistent directed graph based on adjacency intervals.
4;;
5;; Copyright 2010-2011 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  make-random-gnp-digraph)
26
27                   
28 (import scheme chicken)
29 (require-extension rb-tree)
30 (require-library cis )
31 (import (prefix cis cis:))
32 (import (only data-structures alist-ref compose)
33         (only srfi-1 append-reverse delete-duplicates))
34
35(define (interval-digraph: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 'digraph (get-output-string port)))
42          (begin (display (car objs) port)
43                 (display " " port)
44                 (loop (cdr objs)))))))
45
46(define (alist-update k v alst #!optional (eq eq?))
47  (cons (cons k v)
48        (let recur ((alst alst) (ax '()))
49          (cond ((null? alst) (reverse ax))
50                ((eq k (car (car alst))) (recur (cdr alst) ax))
51                (else (recur (cdr alst) (cons (car alst) ax)))))))
52
53(define (node-set-lookup-compare x y)
54  (if (cis:subset? x y)  0
55      (let ((xmax (cis:get-max x))
56            (xmin (cis:get-min x))
57            (ymax (cis:get-max y))
58            (ymin (cis:get-min y)))
59        (cond ((fx= ymax xmax) (fx- ymin xmin))
60              (else (fx- ymax xmax))))))
61       
62(define (node-set-insdel-compare x y)
63  (let ((xmax (cis:get-max x))
64        (xmin (cis:get-min x))
65        (ymax (cis:get-max y))
66        (ymin (cis:get-min y)))
67    (cond ((fx= ymax xmax) (fx- ymin xmin))
68          (else (fx- ymax xmax)))))
69
70(define (make-prop-tree)
71  (make-persistent-map node-set-lookup-compare 
72                       insdel-key-compare: node-set-insdel-compare))
73
74(define-record-type interval-digraph
75  (make-interval-digraph name label nodes succs node-props edge-props )
76  interval-digraph?
77  (name        graph-name)
78  (label       graph-label)
79  (nodes       graph-nodes)
80  (succs       graph-succs)
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-) 
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 node-props  (graph-node-props graph-instance))
98  (define edge-props  (graph-edge-props graph-instance))
99
100  (define (get-nodes) (cis:elements nodes))
101 
102  (define (get-nodes-with-labels) 
103    (let ((node-labels (alist-ref 'label node-props)))
104      (cis:fold-right (lambda (i ax) 
105                        (let ((label ((node-labels 'get-value) (cis:singleton i) #f)))
106                          (cons (list i label)  ax))) 
107                      '() 
108                      nodes)))
109
110
111  (define (get-edges) 
112    ((succs 'foldi)
113     (lambda (i succ-set ax) 
114       (cis:fold-left (lambda (j ax) (cons (list i j) ax)) 
115                      ax succ-set))
116     '()))
117
118
119  (define (get-edges-with-labels) 
120    ((succs 'foldi)
121     (lambda (i succ-set ax) 
122       (let* ((edge-labels (alist-ref 'label edge-props))
123              (i-labels    ((edge-labels 'get-value) (cis:singleton i) make-prop-tree)))
124         (cis:fold-left (lambda (j ax) 
125                          (let ((l ((i-labels 'get-value) (cis:singleton j) #f)))
126                            (cons (list i j l) ax))) 
127                        ax succ-set)))
128     '() ))
129
130
131  (define (order)  (cis:cardinal nodes) )
132
133  (define (size)    ((succs 'fold) (lambda (succ-set ax) (+ (cis:cardinal succ-set) ax))))
134
135  (define capacity order)
136
137  (define (add-node i #!key (label #f) )
138    (make-interval-digraph 
139     name label
140     (cis:add i nodes)
141     succs 
142     (if label 
143         (let ((node-labels (alist-ref 'label node-props)))
144           (alist-update 'label ((node-labels 'put) (cis:singleton i) label) node-props))
145         node-props)
146     edge-props
147     ))
148
149  (define (add-node-interval i #!key (label #f) )
150    (make-interval-digraph 
151     name label
152     (cis:union i nodes)
153     succs 
154     (if label 
155         (let ((node-labels (alist-ref 'label node-props)))
156           (alist-update 'label ((node-labels 'put) i label) node-props))
157         node-props)
158     edge-props
159     ))
160           
161
162  (define (add-edge e #!key (label #f))
163    (cond ((and (pair? e) (pair? (cdr e)))
164
165           (let ((i (car e)) (j (cadr e)))
166
167             (and (cis:in? i nodes) (cis:in? j nodes) 
168
169                    (let ((oi ((succs 'get-value) i cis:empty)))
170                     
171                      (let ((succs1 ((succs 'put) i (cis:add j oi))))
172                       
173                        (make-interval-digraph 
174                         name label 
175                         nodes 
176                         succs1 
177                         node-props
178                         (if label 
179                             (let* ((edge-labels  (alist-ref 'label edge-props))
180                                    (i-labels     ((edge-labels 'get-value) (cis:singleton i) make-prop-tree))
181                                    (i-labels1    ((i-labels 'put) (cis:singleton j) label))
182                                    (edge-labels1 ((edge-labels 'put) (cis:singleton i) i-labels1)))
183                               (alist-update 'label edge-labels1  edge-props))
184                             edge-props)
185                         ))))
186             ))
187          (else (interval-digraph:error 'add-edge ": invalid edge " e))))
188
189
190  (define (add-edge-interval e )
191    (cond ((and (pair? e) (pair? (cdr e)))
192
193           (let ((i (car e)) (js (cadr e)))
194
195             (and (cis:in? i nodes) (cis:subset? js nodes) 
196
197                    (let* ((oi ((succs 'get-value) i cis:empty)))
198                     
199                      (let ((succs1 ((succs 'put) i (cis:union js oi))))
200                       
201                        (make-interval-digraph 
202                         name label 
203                         nodes 
204                         succs1 
205                         node-props
206                         edge-props
207                         ))))
208             ))
209          (else (interval-digraph:error 'add-edge-interval ": invalid edge interval " e))))
210
211 
212
213  (define (get-succ i)           (and (cis:in? i nodes) (cis:elements ((succs 'get-value) i cis:empty))))
214
215  (define (get-succ-interval i)  (and (cis:in? i nodes) ((succs 'get-value) i cis:empty)))
216
217  (define (out-edges i)          (and (cis:in? i nodes) 
218                                      (let ((succ-set ((succs 'get-value) i cis:empty)))
219                                        (cis:fold-left (lambda (j ax) (cons (list i j) ax)) '() 
220                                                       succ-set))))
221
222  (define (has-edge i j)         (and (cis:in? i nodes)
223                                      (cis:in? j ((succs 'get-value) i cis:empty))))
224                                       
225 
226  (define (has-node i)           (cis:in? i nodes) )
227
228
229  (define (has-node-interval i)  (cis:subset? i nodes) )
230
231
232  (define (edge-property-list-keys)   (map car edge-props))
233
234  (define (edge-property-list-map i)  (and (cis:in? i nodes)
235                                           (map
236                                            (lambda (p) 
237                                              (let ((prop-key (car p))
238                                                    (prop-map (cdr p)))
239                                                (let ((i-prop ((prop-map 'get-value) (cis:singleton i) #f)))
240                                                  (cons prop-key i-prop))))
241                                            edge-props)))
242
243  (define (edge-property p i j)  (and (cis:in? i nodes) (cis:in? j nodes) 
244                                      (let* ((prop (alist-ref p edge-props))
245                                             (i-prop (and prop ((prop 'get-value) (cis:singleton i) #f))))
246                                         (and i-prop ((i-prop 'get-value) (cis:singleton j) #f)))))
247   
248
249  (define (edge-property-set p i j v)   (and (has-edge i j)
250                                             (make-interval-digraph name label
251                                                                    nodes succs 
252                                                                    node-props
253                                                                    (let* ((prop    (or (alist-ref p edge-props) (make-prop-tree)))
254                                                                           (i-prop  ((prop 'get-value) (cis:singleton i) make-prop-tree))
255                                                                           (i-prop1 ((i-prop 'put) (cis:singleton j) v))
256                                                                           (prop1   ((prop 'put) (cis:singleton i) i-prop1)))
257                                                                      (alist-update p prop1 edge-props))
258                                                                    )))
259
260  (define (edge-interval-property p i j)   (and (cis:cis? i) (cis:cis? j) 
261                                                (and (cis:subset? i nodes)  (cis:subset? j nodes)
262                                                     (let* ((prop (alist-ref p edge-props))
263                                                            (i-prop (and prop ((prop 'get-value) i #f))))
264                                                       (and i-prop ((i-prop 'get-value) j #f))))))
265
266  (define (edge-interval-property-set p i j v)   (and (cis:cis? i) (cis:cis? j) 
267                                                      (and (cis:subset? i nodes) (cis:subset? j nodes) 
268                                                           (make-interval-digraph name label
269                                                                                  nodes succs 
270                                                                                  node-props
271                                                                                  (let* ((prop    (or (alist-ref p edge-props) (make-prop-tree)))
272                                                                                         (i-prop  ((prop 'get-value) i make-prop-tree))
273                                                                                         (i-prop1 ((i-prop 'put) j v))
274                                                                                         (prop1   ((prop 'put) i i-prop1)))
275                                                                                   
276                                                                                    (alist-update p prop1 edge-props))
277                                                                                  ))))
278
279  (define (edge-interval-prototype p i j)   (and (cis:cis? i) (cis:cis? j) 
280                                                (and (cis:subset? i nodes)  (cis:subset? j nodes)
281                                                     (let* ((prop (alist-ref p edge-props))
282                                                            (i-prop (and prop ((prop 'get-value) i #f))))
283                                                       (let ((proto-function (and i-prop ((i-prop 'get-value) j #f))))
284                                                         (and proto-function (proto-function graph-instance i j)))
285                                                       ))
286                                                ))
287
288  (define (edge-interval-prototype-set p i j v)   (and (cis:cis? i) (cis:cis? j) (procedure? v)
289                                                      (and (cis:subset? i nodes) (cis:subset? j nodes) 
290                                                           (make-interval-digraph name label
291                                                                                  nodes succs 
292                                                                                  node-props
293                                                                                  (let* ((prop    (or (alist-ref p edge-props) (make-prop-tree)))
294                                                                                         (i-prop  ((prop 'get-value) i make-prop-tree))
295                                                                                         (i-prop1 ((i-prop 'put) j v))
296                                                                                         (prop1   ((prop 'put) i i-prop1)))
297                                                                                    (alist-update p prop1 edge-props))
298                                                                                  ))
299                                                      ))
300
301  (define (node-property-list-keys)    (map car node-props))
302
303  (define (node-property p i)    (and (cis:in? i nodes)
304                                      (let ((prop (alist-ref p node-props)))
305                                        (and prop ((prop 'get-value) (cis:singleton i) #f)))))
306
307                                     
308  (define (node-property-set p i v)    (and (cis:in?  i nodes) 
309                                            (make-interval-digraph name label
310                                                                   nodes succs 
311                                                                   (let* ((prop (or (alist-ref p node-props) (make-prop-tree)))
312                                                                          (prop1 ((prop 'put) (cis:singleton i) v)))
313                                                                     (alist-update p prop1 node-props))
314                                                                   edge-props
315                                                                   )))
316
317  (define (node-interval-property p i)   (and (cis:cis? i) 
318                                              (and (cis:subset? i nodes)
319                                                   (let ((prop  (alist-ref p node-props)))
320                                                     (and prop ((prop 'get-value) i #f))))))
321
322
323  (define (node-interval-property-set p i v)   (and (cis:cis? i)
324                                                    (and (cis:subset? i nodes) 
325                                                         (make-interval-digraph name label
326                                                                                nodes
327                                                                                succs 
328                                                                                (let* ((prop  (or (alist-ref p node-props) (make-prop-tree)))
329                                                                                       (prop1 ((prop 'put) i v)))
330                                                                                  (alist-update p prop1 node-props))
331                                                                                edge-props
332                                                                                ))))
333
334  (define (node-label i)     (node-property 'label i))
335
336  (define (node-label-set i v)   (node-property-set 'label i v))
337
338  (define (foreach-node f)   (cis:foreach (lambda (i) (f i)) nodes))
339
340
341  (define (foreach-node-with-label f)   
342    (let ((node-labels (alist-ref 'label node-props)))
343      (cis:foreach (lambda (i) (f i ((node-labels 'get) i))) nodes)))
344
345
346  (define (foreach-edge f) 
347    ((succs 'for-each-ascending) 
348     (lambda (e) 
349       (let ((i (car e)))
350         (cis:foreach (lambda (j) (f i j)) (cdr e)))
351       )))
352
353
354  (define (foreach-edge-with-property f p) 
355    (let ((props (alist-ref p edge-props)))
356      ((succs 'for-each-ascending) 
357       (lambda (e) 
358         (let* ((i (car e))
359                (i-prop ((props 'get-value) (cis:singleton i) #f)))
360           (if i-prop
361               (cis:foreach (lambda (j) (f i j ((i-prop 'get-value) (cis:singleton j) #f))) (cdr e))
362               (cis:foreach (lambda (j) (f i j #f)) (cdr e))))
363           ))
364       ))
365
366
367  ;; Dispatcher
368  (lambda (selector)
369      (case selector
370        ;; accessors
371        ((name)                        name)
372        ((label)                       label)
373        ((nodes)                       get-nodes)
374        ((nodes-with-labels)           get-nodes-with-labels)
375        ((node-intervals)              nodes)
376        ((edges)                       get-edges)
377        ((edges-with-labels)           get-edges-with-labels)
378        ((order)                       order)
379        ((size)                        size)
380        ((capacity)                    capacity)
381        ((out-edges)                   out-edges)
382        ((succ)                        get-succ)
383        ((succ-interval)               get-succ-interval)
384        ((has-edge)                    has-edge)
385        ((has-node)                    has-node)
386        ((has-node-interval)           has-node-interval)
387        ((node-property-list-keys)          node-property-list-keys)
388        ((node-property)               node-property)
389        ((node-label)                  node-label)
390        ((node-interval-property)      node-interval-property)
391        ((edge-property-list-keys)         edge-property-list-keys)
392        ((edge-property-list-map)          edge-property-list-map)
393        ((edge-property)               edge-property)
394        ((edge-interval-property)      edge-interval-property)
395        ((edge-interval-prototype)     edge-interval-prototype)
396        ((foreach-node)                foreach-node)
397        ((foreach-node-with-label)     foreach-node-with-label)
398        ((foreach-edge)                foreach-edge)       
399        ((foreach-edge-with-property)  foreach-edge-with-property)
400       
401
402        ;; transformers
403        ((add-node)                    (compose interval-digraph-operations add-node))
404        ((add-node-interval)           (compose interval-digraph-operations add-node-interval))
405        ((add-edge)                    (compose interval-digraph-operations add-edge))
406        ((add-edge-interval)           (compose interval-digraph-operations add-edge-interval))
407        ((node-label-set)              (compose interval-digraph-operations node-label-set))
408        ((node-property-set)           (compose interval-digraph-operations node-property-set))
409        ((node-interval-property-set)  (compose interval-digraph-operations node-interval-property-set))
410        ((edge-property-set)           (compose interval-digraph-operations edge-property-set))
411        ((edge-interval-property-set)  (compose interval-digraph-operations edge-interval-property-set))
412        ((edge-interval-prototype-set) (compose interval-digraph-operations edge-interval-prototype-set))
413       
414        (else
415          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
416)
417
418
419
420
421(define (make-digraph name label) (interval-digraph-operations (empty-graph name label)))
422
423
424(define (merge a b compare merge-fn)
425  (let recur ((a a) (b b) (l '()))
426    (cond ((and (null? a) (null? b)) (reverse l))
427          ((null? a) (append-reverse l b))
428          ((null? b) (append-reverse l a))
429          (else
430           (let ((c (compare (car a) (car b))))
431             (cond ((negative? c)  (recur (cdr a) b (cons (car a) l)))
432                   ((zero? c)      (recur (cdr a) (cdr b) (cons (merge-fn (car a) (car b)) l)))
433                   ((positive? c)  (recur a (cdr b) (cons (car b) l))))))
434          )))
435
436
437
438(define (digraph-union a b merge-label)
439
440  (define (merge-nodes a b)
441    (merge a b
442     (lambda (x y) (fx- (car x) (car y)))
443     (lambda (x y) x)))
444
445  (define (merge-nodes-with-labels a b)
446    (merge a b
447     (lambda (x y) (fx- (car x) (car y)))
448     (lambda (x y) (list (car x) (merge-label (cadr x) (cadr y))))))
449
450  (define (merge-edges a b)
451    (merge a b
452     (lambda (x y) (let ((c (fx- (car x) (car y))))
453                     (if (zero? c) (fx- (cadr x) (cadr y)) c)))
454     (lambda (x y) x)))
455
456  (define (merge-edges-with-labels a b)
457    (merge a b
458           (lambda (x y) (let ((c (fx- (car x) (car y))))
459                           (if (zero? c) (fx- (cadr x) (cadr y)) c)))
460           (lambda (x y) (list (car x) (cadr x) (merge-label (caddr x) (caddr y))))))
461
462 
463  (let recur ((a a) (b b))
464
465    (let* (;; accessors
466           (name                  (string-append "union " (a 'name) (b 'name)))
467           (label                 (merge-label (a 'label) (b 'label)))
468           (nodes                 (lambda () (cis:elements (cis:union (a 'node-intervals) (b 'node-intervals)))))
469           (nodes-with-labels     (lambda ()
470                                    (merge-nodes-with-labels
471                                     (a 'nodes-with-labels)
472                                     (b 'nodes-with-labels))))
473           (node-intervals        (lambda () (cis:union (a 'node-intervals) (b 'node-intervals))))
474           (edges                 (lambda () (merge-edges (a 'edges) (b 'edges))))
475           (edges-with-labels     (lambda () (merge-edges-with-labels 
476                                              (a 'edges-with-labels) 
477                                              (b 'edges-with-labels))))
478           (order                  (lambda () (cis:cardinal (cis:union (a 'node-intervals) (b 'node-intervals)))))
479           (size                   (lambda () (length (edges))))
480           (capacity               order)
481           (out-edges                (lambda (i)   (merge-edges ((a 'out-edges) i) ((b 'out-edges) i))))
482           (succ                     (lambda (i)   (cis:elements (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i)))))
483           (succ-interval            (lambda (i)   (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i))))
484           (has-edge                 (lambda (i j) (or ((a 'has-edge) i j) ((b 'has-edge) i j))))
485           (has-node                 (lambda (i)   (or ((a 'has-node) i) ((b 'has-node) i))))
486           (has-node-interval        (lambda (i)   (or ((a 'has-node-interval) i) ((b 'has-node-interval) i))))
487           (node-property-list-keys       (lambda ()   (delete-duplicates (append ((a 'node-property-list-keys)) ((b 'node-property-list-keys))))))
488           (node-property            (lambda (p i)  (or ((a 'node-property) p i) ((b 'node-property) p i))))
489           (node-interval-property   (lambda (p i)  (or ((a 'node-interval-property) p i) ((b 'node-interval-property) p i))))
490           (node-label               (lambda (i)    (or ((a 'node-label) i) ((b 'node-label) i))))
491           (edge-property-list-keys  (lambda () (delete-duplicates (append ((a 'edge-property-list-keys)) ((b 'edge-property-list-keys))))))
492           (edge-property-list-map   (lambda () (delete-duplicates (append ((a 'edge-property-list-map)) ((b 'edge-property-list-map))))))
493           (edge-property            (lambda (p i j)  (or ((a 'edge-property) p i j) ((b 'edge-property) i j))))
494           (edge-interval-property   (lambda (p i j)  (or ((a 'edge-interval-property) p i j) ((b 'edge-interval-property) i j))))
495           (foreach-node             (lambda (f) (for-each f (nodes))))
496           (foreach-node-with-label  (lambda (f) (for-each f (nodes-with-labels))))
497           (foreach-edge             (lambda (f) (for-each f (edges))))
498
499           ;; transformers
500           (add-node
501            (lambda (n #!key (label #f))
502              (recur ((a 'add-node) n label: label) ((b 'add-node) n label: label))))
503           (add-node-interval
504            (lambda (i #!key (label #f))
505              (recur ((a 'add-node-interval) i label: label) ((b 'add-node-interval) i label: label))))
506           (add-edge-interval 
507            (lambda (e)
508              (recur ((a 'add-edge-interval) e) ((b 'add-edge-interval) e))))
509                         
510           (edge-interval-property-set     
511            (lambda (p i j v)  (let* ((a1 ((a 'edge-interval-property-set) p i j v))
512                                      (b1 (and (not a1) ((b 'edge-interval-property-set) p i j v))))
513                                 (cond (a1 (recur a1 b))
514                                       (b1 (recur a b1))
515                                       (else (recur a b))))))
516           (node-interval-property-set     
517            (lambda (p i v)    (let* ((a1 ((a 'node-interval-property-set) p i v))
518                                      (b1 (and (not a1) ((b 'node-interval-property-set) p i v))))
519                                 (cond (a1 (recur a1 b))
520                                       (b1 (recur a b1))
521                                       (else (recur a b))))))
522           (node-label-set         
523            (lambda (i v)      (let* ((a1 ((a 'node-label-set) i v))
524                                      (b1 (and (not a1) ((b 'node-label-set) i v))))
525                                 (cond (a1 (recur a1 b))
526                                       (b1 (recur a b1))
527                                       (else (recur a b))))))
528           (node-property-set     
529            (lambda (p i v)    (let* ((a1 ((a 'node-property-set) p i v))
530                                      (b1 (and (not a1) ((b 'node-property-set) p i v))))
531                                 (cond (a1 (recur a1 b))
532                                       (b1 (recur a b1))
533                                       (else (recur a b))))))
534           (edge-property-set     
535            (lambda (p i j v)  (let* ((a1 ((a 'edge-property-set) p i j v))
536                                      (b1 (and (not a1) ((b 'edge-property-set) p i j v))))
537                                 (cond (a1 (recur a1 b))
538                                       (b1 (recur a b1))
539                                       (else (recur a b))))))
540                                 
541           )
542
543    (lambda (selector)
544      (case selector
545        ;; accessors
546        ((name)                        name)
547        ((label)                       label)
548        ((nodes)                       nodes)
549        ((nodes-with-labels)           nodes-with-labels)
550        ((node-intervals)              node-intervals)
551        ((edges)                       edges)
552        ((edges-with-labels)           edges-with-labels)
553        ((order)                       order)
554        ((size)                        size)
555        ((capacity)                    capacity)
556        ((out-edges)                   out-edges)
557        ((succ)                        succ)
558        ((succ-interval)               succ-interval)
559        ((has-edge)                    has-edge)
560        ((has-node)                    has-node)
561        ((has-node-interval)           has-node-interval)
562        ((node-property-list-keys)          node-property-list-keys)
563        ((node-property)               node-property)
564        ((node-interval-property)      node-interval-property)
565        ((node-label)                  node-label)
566        ((edge-property)               edge-property)
567        ((edge-property-list-keys)     edge-property-list-keys)
568        ((edge-property-list-map)      edge-property-list-map)
569        ((foreach-node)                foreach-node)
570        ((foreach-node-with-label)     foreach-node-with-label)
571        ((foreach-edge)                foreach-edge)
572
573        ;; transformers
574        ((add-node)                    add-node)
575        ((add-node-interval)           add-node-interval)
576        ((add-edge-interval)           add-edge-interval)
577        ((node-label-set)              node-label-set)
578        ((node-property-set)           node-property-set)
579        ((node-interval-property-set)  node-interval-property-set)
580        ((edge-property-set)           edge-property-set)
581        ((edge-interval-property-set)  edge-interval-property-set)
582       
583        (else
584          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
585   
586    )))
587                         
588;;
589;; Adds a number k to all node ids of the graph
590;;
591
592
593(define (digraph-rename k a)
594
595  (define (rename-nodes ns) (map (lambda (x) (list (fx+ k x))) ns))
596  (define (rename-nodes-with-labels ns) (map (lambda (x) (list (fx+ k (car x)) (cadr x))) ns))
597  (define (rename-edges es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)))) es))
598  (define (rename-edges-with-labels es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)) (caddr e))) es))
599
600  (let recur ((a a))
601
602    (let* (;; accessors
603           (name                     (a 'name))
604           (label                    (a 'label))
605           (nodes                    (lambda () (cis:elements (cis:shift k (a 'node-intervals) ))))
606           (nodes-with-labels        (lambda () (rename-nodes-with-labels (a 'nodes-with-labels))))
607           (node-intervals           (lambda () (cis:shift k (a 'node-intervals) )))
608           (edges                    (lambda () (rename-edges (a 'edges) )))
609           (edges-with-labels        (lambda () (rename-edges-with-labels (a 'edges-with-labels) )))
610           (order                    (lambda () (a 'order)))
611           (size                     (lambda () (a 'size)))
612           (capacity                 order)
613           (out-edges                (lambda (i)      (rename-edges ((a 'out-edges) (fx- i k)))))
614           (succ                     (lambda (i)      (cis:elements (cis:shift k ((a 'succ-interval) (fx- i k) )))))
615           (succ-interval            (lambda (i)      (cis:shift k ((a 'succ-interval) (fx- i k) ))))
616           (has-edge                 (lambda (i j)    ((a 'has-edge) (fx- i k) (fx- j k))))
617           (has-node                 (lambda (i)      ((a 'has-node) (fx- i k))))
618           (has-node-interval        (lambda (i)      ((a 'has-node-interval) (cis:shift (fxneg k) i))))
619           (node-property-list-keys       (a 'node-property-list-keys))
620           (node-property            (lambda (p i)    ((a 'node-property) p (fx- i k) )))
621           (node-interval-property   (lambda (p i)    ((a 'node-interval-property) p (cis:shift (fxneg k) i) )))
622           (node-label               (lambda (i)      ((a 'node-label) (fx- i k))))
623           (edge-property-list-keys       (a 'edge-property-list-keys))
624           (edge-property-list-map        (a 'edge-property-list-map))
625           (edge-property            (lambda (p i j)  ((a 'edge-property) p (fx- i k) (fx- j k) )))
626           (edge-interval-property   (lambda (p i j)  ((a 'edge-interval-property) p (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) )))
627           (foreach-node             (lambda (f)      (for-each (lambda (i) (f (fx+ i k))) (nodes))))
628           (foreach-node-with-label  (lambda (f)      (for-each (lambda (x) (f (fx+ (car x) k) (cadr x))) (nodes-with-labels))))
629           (foreach-edge             (lambda (f)      (for-each (lambda (e) (f (list (fx+ (car e) k) (fx+ (cadr e) k)))) (edges))))
630           
631           ;; transformers
632           (add-node    (lambda (n #!key (label #f))  (recur ((a 'add-node) (fx- n k) label: label) )))
633
634           (add-node-interval    (lambda (i #!key (label #f))  (recur ((a 'add-node-interval) (cis:shift (fxneg k) i) label: label) )))
635
636           (add-edge    (lambda (e #!key (label #f))  (recur ((a 'add-edge) (list (fx- (car e) k) (fx- (cadr e) k)) label: label) )))
637           (add-edge-interval (lambda (e)  (recur ((a 'add-edge-interval) (list (fx- (car e) k) (fx- (cadr e) k)) ))))
638
639           (edge-interval-property-set     
640            (lambda (p i j v)  (recur ((a 'edge-interval-property-set) p 
641                                       (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) v))))
642
643           (node-interval-property-set     
644            (lambda (p i v)    (recur ((a 'node-interval-property-set) p 
645                                       (cis:shift (fxneg k) i) v))))
646
647           (node-label-set         
648            (lambda (i v)      (recur ((a 'node-label-set) (fx- i k) v))))
649
650           (node-property-set     
651            (lambda (p i v)    (recur ((a 'node-property-set) p (fx- i k) v))))
652
653           (edge-property-set     
654            (lambda (p i j v)  (recur ((a 'edge-property-set) p (fx- i k) (fx- j k) v))))
655
656           )
657     
658    (lambda (selector)
659      (case selector
660        ;; accessors
661        ((name)                        name)
662        ((label)                       label)
663        ((nodes)                       nodes)
664        ((nodes-with-labels)           nodes-with-labels)
665        ((node-intervals)              node-intervals)
666        ((edges)                       edges)
667        ((edges-with-labels)           edges-with-labels)
668        ((order)                       order)
669        ((size)                        size)
670        ((capacity)                    capacity)
671        ((out-edges)                   out-edges)
672        ((succ)                        succ)
673        ((succ-interval)               succ-interval)
674        ((has-edge)                    has-edge)
675        ((has-node)                    has-node)
676        ((has-node-interval)           has-node-interval)
677        ((node-property-list-keys)          node-property-list-keys)
678        ((node-property)               node-property)
679        ((node-interval-property)      node-interval-property)
680        ((node-label)                  node-label)
681        ((edge-property-list-keys)     edge-property-list-keys)
682        ((edge-property-list-map)      edge-property-list-map)
683        ((edge-property)               edge-property)
684        ((foreach-node)                foreach-node)
685        ((foreach-node-with-label)     foreach-node-with-label)
686        ((foreach-edge)                foreach-edge)
687
688        ;; transformers
689        ((add-node)                    add-node)
690        ((add-node-interval)           add-node-interval)
691        ((add-edge)                    add-edge)
692        ((add-edge-interval)           add-edge-interval)
693        ((node-label-set)              node-label-set)
694        ((node-property-set)           node-property-set)
695        ((node-interval-property-set)  node-interval-property-set)
696        ((edge-property-set)           edge-property-set)
697        ((edge-interval-property-set)  edge-interval-property-set)
698       
699        (else
700          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
701   
702    )))
703
704
705(define (digraph-disjoint-union a b) (digraph-union a (digraph-rename ((a 'capacity)) b)))
706
707;;
708;; Naive implementation: randomly choosing edges from NxN possibilities with probability P
709;;
710
711(define (make-random-gnp-digraph name label N P R S loops)
712
713  (if (< N 10) (error 'make-random-gnp-digraph "N is too small" N))
714  (if (not (and (< 0 P) (<= P 1))) (error 'make-random-gnp-digraph "P must be in the interval (0, 1]"))
715
716  (let* ((E     (* N N))
717         (nodes (cis:interval 1 N))
718         (a     (make-digraph name label))
719         (a     ((a 'add-node-interval) nodes)))
720   
721    (let recur ((a a) (s S) (e 0))
722
723      (if (> e E) a
724
725          (let* ((i (inexact->exact (R N P s)))
726                 (j (inexact->exact (R N P s))))
727
728            (if (or (zero? i) (zero? j) (and (= i j) (not loops)) ((a 'has-edge) i j))
729                (recur a s (+ 1 e))
730                (recur ((a 'add-edge) (list i j)) s (+ 1 e))
731                )))
732    )))
733
734
735)
Note: See TracBrowser for help on using the repository browser.