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

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

interval-digraph: restructuring internals and eliminating predecessor map

File size: 27.0 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) ((succs 'for-each-ascending) 
347                            (lambda (i v)  (cis:foreach (lambda (j) (f i j)) v))))
348
349
350  ;; Dispatcher
351  (lambda (selector)
352      (case selector
353        ;; accessors
354        ((name)                        name)
355        ((label)                       label)
356        ((nodes)                       get-nodes)
357        ((nodes-with-labels)           get-nodes-with-labels)
358        ((node-intervals)              nodes)
359        ((edges)                       get-edges)
360        ((edges-with-labels)           get-edges-with-labels)
361        ((order)                       order)
362        ((size)                        size)
363        ((capacity)                    capacity)
364        ((out-edges)                   out-edges)
365        ((succ)                        get-succ)
366        ((succ-interval)               get-succ-interval)
367        ((has-edge)                    has-edge)
368        ((has-node)                    has-node)
369        ((has-node-interval)           has-node-interval)
370        ((node-property-list-keys)          node-property-list-keys)
371        ((node-property)               node-property)
372        ((node-label)                  node-label)
373        ((node-interval-property)      node-interval-property)
374        ((edge-property-list-keys)         edge-property-list-keys)
375        ((edge-property-list-map)          edge-property-list-map)
376        ((edge-property)               edge-property)
377        ((edge-interval-property)      edge-interval-property)
378        ((edge-interval-prototype)     edge-interval-prototype)
379        ((foreach-node)                foreach-node)
380        ((foreach-node-with-label)     foreach-node-with-label)
381        ((foreach-edge)                foreach-edge)
382
383        ;; transformers
384        ((add-node)                    (compose interval-digraph-operations add-node))
385        ((add-node-interval)           (compose interval-digraph-operations add-node-interval))
386        ((add-edge)                    (compose interval-digraph-operations add-edge))
387        ((add-edge-interval)           (compose interval-digraph-operations add-edge-interval))
388        ((node-label-set)              (compose interval-digraph-operations node-label-set))
389        ((node-property-set)           (compose interval-digraph-operations node-property-set))
390        ((node-interval-property-set)  (compose interval-digraph-operations node-interval-property-set))
391        ((edge-property-set)           (compose interval-digraph-operations edge-property-set))
392        ((edge-interval-property-set)  (compose interval-digraph-operations edge-interval-property-set))
393        ((edge-interval-prototype-set) (compose interval-digraph-operations edge-interval-prototype-set))
394       
395        (else
396          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
397)
398
399
400
401
402(define (make-digraph name label) (interval-digraph-operations (empty-graph name label)))
403
404
405(define (merge a b compare merge-fn)
406  (let recur ((a a) (b b) (l '()))
407    (cond ((and (null? a) (null? b)) (reverse l))
408          ((null? a) (append-reverse l b))
409          ((null? b) (append-reverse l a))
410          (else
411           (let ((c (compare (car a) (car b))))
412             (cond ((negative? c)  (recur (cdr a) b (cons (car a) l)))
413                   ((zero? c)      (recur (cdr a) (cdr b) (cons (merge-fn (car a) (car b)) l)))
414                   ((positive? c)  (recur a (cdr b) (cons (car b) l))))))
415          )))
416
417
418
419(define (digraph-union a b merge-label)
420
421  (define (merge-nodes a b)
422    (merge a b
423     (lambda (x y) (fx- (car x) (car y)))
424     (lambda (x y) x)))
425
426  (define (merge-nodes-with-labels a b)
427    (merge a b
428     (lambda (x y) (fx- (car x) (car y)))
429     (lambda (x y) (list (car x) (merge-label (cadr x) (cadr y))))))
430
431  (define (merge-edges a b)
432    (merge a b
433     (lambda (x y) (let ((c (fx- (car x) (car y))))
434                     (if (zero? c) (fx- (cadr x) (cadr y)) c)))
435     (lambda (x y) x)))
436
437  (define (merge-edges-with-labels a b)
438    (merge a b
439           (lambda (x y) (let ((c (fx- (car x) (car y))))
440                           (if (zero? c) (fx- (cadr x) (cadr y)) c)))
441           (lambda (x y) (list (car x) (cadr x) (merge-label (caddr x) (caddr y))))))
442
443 
444  (let recur ((a a) (b b))
445
446    (let* (;; accessors
447           (name                  (string-append "union " (a 'name) (b 'name)))
448           (label                 (merge-label (a 'label) (b 'label)))
449           (nodes                 (lambda () (cis:elements (cis:union (a 'node-intervals) (b 'node-intervals)))))
450           (nodes-with-labels     (lambda ()
451                                    (merge-nodes-with-labels
452                                     (a 'nodes-with-labels)
453                                     (b 'nodes-with-labels))))
454           (node-intervals        (lambda () (cis:union (a 'node-intervals) (b 'node-intervals))))
455           (edges                 (lambda () (merge-edges (a 'edges) (b 'edges))))
456           (edges-with-labels     (lambda () (merge-edges-with-labels 
457                                              (a 'edges-with-labels) 
458                                              (b 'edges-with-labels))))
459           (order                  (lambda () (cis:cardinal (cis:union (a 'node-intervals) (b 'node-intervals)))))
460           (size                   (lambda () (length (edges))))
461           (capacity               order)
462           (out-edges                (lambda (i)   (merge-edges ((a 'out-edges) i) ((b 'out-edges) i))))
463           (succ                     (lambda (i)   (cis:elements (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i)))))
464           (succ-interval            (lambda (i)   (cis:union ((a 'succ-interval) i)  ((b 'succ-interval) i))))
465           (has-edge                 (lambda (i j) (or ((a 'has-edge) i j) ((b 'has-edge) i j))))
466           (has-node                 (lambda (i)   (or ((a 'has-node) i) ((b 'has-node) i))))
467           (has-node-interval        (lambda (i)   (or ((a 'has-node-interval) i) ((b 'has-node-interval) i))))
468           (node-property-list-keys       (lambda ()   (delete-duplicates (append ((a 'node-property-list-keys)) ((b 'node-property-list-keys))))))
469           (node-property            (lambda (p i)  (or ((a 'node-property) p i) ((b 'node-property) p i))))
470           (node-interval-property   (lambda (p i)  (or ((a 'node-interval-property) p i) ((b 'node-interval-property) p i))))
471           (node-label               (lambda (i)    (or ((a 'node-label) i) ((b 'node-label) i))))
472           (edge-property-list-keys       (lambda () (delete-duplicates (append ((a 'edge-property-list-keys)) ((b 'edge-property-list-keys))))))
473           (edge-property            (lambda (p i j)  (or ((a 'edge-property) p i j) ((b 'edge-property) i j))))
474           (edge-interval-property   (lambda (p i j)  (or ((a 'edge-interval-property) p i j) ((b 'edge-interval-property) i j))))
475           (foreach-node             (lambda (f) (for-each f (nodes))))
476           (foreach-node-with-label  (lambda (f) (for-each f (nodes-with-labels))))
477           (foreach-edge             (lambda (f) (for-each f (edges))))
478
479           ;; transformers
480           (add-node
481            (lambda (n #!key (label #f))
482              (recur ((a 'add-node) n label: label) ((b 'add-node) n label: label))))
483           (add-node-interval
484            (lambda (i #!key (label #f))
485              (recur ((a 'add-node-interval) i label: label) ((b 'add-node-interval) i label: label))))
486           (add-edge-interval 
487            (lambda (e)
488              (recur ((a 'add-edge-interval) e) ((b 'add-edge-interval) e))))
489                         
490           (edge-interval-property-set     
491            (lambda (p i j v)  (let* ((a1 ((a 'edge-interval-property-set) p i j v))
492                                      (b1 (and (not a1) ((b 'edge-interval-property-set) p i j v))))
493                                 (cond (a1 (recur a1 b))
494                                       (b1 (recur a b1))
495                                       (else (recur a b))))))
496           (node-interval-property-set     
497            (lambda (p i v)    (let* ((a1 ((a 'node-interval-property-set) p i v))
498                                      (b1 (and (not a1) ((b 'node-interval-property-set) p i v))))
499                                 (cond (a1 (recur a1 b))
500                                       (b1 (recur a b1))
501                                       (else (recur a b))))))
502           (node-label-set         
503            (lambda (i v)      (let* ((a1 ((a 'node-label-set) i v))
504                                      (b1 (and (not a1) ((b 'node-label-set) i v))))
505                                 (cond (a1 (recur a1 b))
506                                       (b1 (recur a b1))
507                                       (else (recur a b))))))
508           (node-property-set     
509            (lambda (p i v)    (let* ((a1 ((a 'node-property-set) p i v))
510                                      (b1 (and (not a1) ((b 'node-property-set) p i v))))
511                                 (cond (a1 (recur a1 b))
512                                       (b1 (recur a b1))
513                                       (else (recur a b))))))
514           (edge-property-set     
515            (lambda (p i j v)  (let* ((a1 ((a 'edge-property-set) p i j v))
516                                      (b1 (and (not a1) ((b 'edge-property-set) p i j v))))
517                                 (cond (a1 (recur a1 b))
518                                       (b1 (recur a b1))
519                                       (else (recur a b))))))
520                                 
521           )
522
523    (lambda (selector)
524      (case selector
525        ;; accessors
526        ((name)                        name)
527        ((label)                       label)
528        ((nodes)                       nodes)
529        ((nodes-with-labels)           nodes-with-labels)
530        ((node-intervals)              node-intervals)
531        ((edges)                       edges)
532        ((edges-with-labels)           edges-with-labels)
533        ((order)                       order)
534        ((size)                        size)
535        ((capacity)                    capacity)
536        ((out-edges)                   out-edges)
537        ((succ)                        succ)
538        ((succ-interval)               succ-interval)
539        ((has-edge)                    has-edge)
540        ((has-node)                    has-node)
541        ((has-node-interval)           has-node-interval)
542        ((node-property-list-keys)          node-property-list-keys)
543        ((node-property)               node-property)
544        ((node-interval-property)      node-interval-property)
545        ((node-label)                  node-label)
546        ((edge-property)               edge-property)
547        ((edge-property-list-keys)          edge-property-list-keys)
548        ((foreach-node)                foreach-node)
549        ((foreach-node-with-label)     foreach-node-with-label)
550        ((foreach-edge)                foreach-edge)
551
552        ;; transformers
553        ((add-node)                    add-node)
554        ((add-node-interval)           add-node-interval)
555        ((add-edge-interval)           add-edge-interval)
556        ((node-label-set)              node-label-set)
557        ((node-property-set)           node-property-set)
558        ((node-interval-property-set)  node-interval-property-set)
559        ((edge-property-set)           edge-property-set)
560        ((edge-interval-property-set)  edge-interval-property-set)
561       
562        (else
563          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
564   
565    )))
566                         
567;;
568;; Adds a number k to all node ids of the graph
569;;
570
571
572(define (digraph-rename k a)
573
574  (define (rename-nodes ns) (map (lambda (x) (list (fx+ k x))) ns))
575  (define (rename-nodes-with-labels ns) (map (lambda (x) (list (fx+ k (car x) (cadr x)))) ns))
576  (define (rename-edges es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)))) es))
577  (define (rename-edges-with-labels es) (map (lambda (e) (list (fx+ k (car e)) (fx+ k (cadr e)) (caddr e))) es))
578
579  (let recur ((a a))
580
581    (let* (;; accessors
582           (name                     (a 'name))
583           (label                    (a 'label))
584           (nodes                    (lambda () (cis:elements (cis:shift k (a 'node-intervals) ))))
585           (nodes-with-labels        (lambda () (rename-nodes-with-labels (a 'nodes-with-labels))))
586           (node-intervals           (lambda () (cis:shift k (a 'node-intervals) )))
587           (edges                    (lambda () (rename-edges (a 'edges) )))
588           (edges-with-labels        (lambda () (rename-edges-with-labels (a 'edges-with-labels) )))
589           (order                    (lambda () (a 'order)))
590           (size                     (lambda () (a 'size)))
591           (capacity                 order)
592           (out-edges                (lambda (i)      (rename-edges ((a 'out-edges) (fx- i k)))))
593           (succ                     (lambda (i)      (cis:elements (cis:shift k ((a 'succ-interval) (fx- i k) )))))
594           (succ-interval            (lambda (i)      (cis:shift k ((a 'succ-interval) (fx- i k) ))))
595           (has-edge                 (lambda (i j)    ((a 'has-edge) (fx- i k) (fx- j k))))
596           (has-node                 (lambda (i)      ((a 'has-node) (fx- i k))))
597           (has-node-interval        (lambda (i)      ((a 'has-node-interval) (cis:shift (fxneg k) i))))
598           (node-property-list-keys       (a 'node-property-list-keys))
599           (node-property            (lambda (p i)    ((a 'node-property) p (fx- i k) )))
600           (node-interval-property   (lambda (p i)    ((a 'node-interval-property) p (cis:shift (fxneg k) i) )))
601           (node-label               (lambda (i)      ((a 'node-label) (fx- i k))))
602           (edge-property-list-keys       (a 'edge-property-list-keys))
603           (edge-property            (lambda (p i j)  ((a 'edge-property) p (fx- i k) (fx- j k) )))
604           (edge-interval-property   (lambda (p i j)  ((a 'edge-interval-property) p (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) )))
605           (foreach-node             (lambda (f)      (for-each (lambda (i) (f (fx+ i k))) (nodes))))
606           (foreach-node-with-label  (lambda (f)      (for-each (lambda (x) (f (fx+ (car x) k) (cadr x))) (nodes-with-labels))))
607           (foreach-edge             (lambda (f)      (for-each (lambda (e) (f (list (fx+ (car e) k) (fx+ (cadr e) k)))) (edges))))
608           
609           ;; transformers
610           (add-node    (lambda (n #!key (label #f))  (recur ((a 'add-node) (fx- n k) label: label) )))
611
612           (add-node-interval    (lambda (i #!key (label #f))  (recur ((a 'add-node-interval) (cis:shift (fxneg k) i) label: label) )))
613
614           (add-edge    (lambda (e #!key (label #f))  (recur ((a 'add-edge) (list (fx- (car e) k) (fx- (cadr e) k)) label: label) )))
615           (add-edge-interval (lambda (e)  (recur ((a 'add-edge-interval) (list (fx- (car e) k) (fx- (cadr e) k)) ))))
616
617           (edge-interval-property-set     
618            (lambda (p i j v)  (recur ((a 'edge-interval-property-set) p 
619                                       (cis:shift (fxneg k) i) (cis:shift (fxneg k) j) v))))
620
621           (node-interval-property-set     
622            (lambda (p i v)    (recur ((a 'node-interval-property-set) p 
623                                       (cis:shift (fxneg k) i) v))))
624
625           (node-label-set         
626            (lambda (i v)      (recur ((a 'node-label-set) (fx- i k) v))))
627
628           (node-property-set     
629            (lambda (p i v)    (recur ((a 'node-property-set) p (fx- i k) v))))
630
631           (edge-property-set     
632            (lambda (p i j v)  (recur ((a 'edge-property-set) p (fx- i k) (fx- j k) v))))
633
634           )
635     
636    (lambda (selector)
637      (case selector
638        ;; accessors
639        ((name)                        name)
640        ((label)                       label)
641        ((nodes)                       nodes)
642        ((nodes-with-labels)           nodes-with-labels)
643        ((node-intervals)              node-intervals)
644        ((edges)                       edges)
645        ((edges-with-labels)           edges-with-labels)
646        ((order)                       order)
647        ((size)                        size)
648        ((capacity)                    capacity)
649        ((out-edges)                   out-edges)
650        ((succ)                        succ)
651        ((succ-interval)               succ-interval)
652        ((has-edge)                    has-edge)
653        ((has-node)                    has-node)
654        ((has-node-interval)           has-node-interval)
655        ((node-property-list-keys)          node-property-list-keys)
656        ((node-property)               node-property)
657        ((node-interval-property)      node-interval-property)
658        ((node-label)                  node-label)
659        ((edge-property-list-keys)          edge-property-list-keys)
660        ((edge-property)               edge-property)
661        ((foreach-node)                foreach-node)
662        ((foreach-node-with-label)     foreach-node-with-label)
663        ((foreach-edge)                foreach-edge)
664
665        ;; transformers
666        ((add-node)                    add-node)
667        ((add-node-interval)           add-node-interval)
668        ((add-edge)                    add-edge)
669        ((add-edge-interval)           add-edge-interval)
670        ((node-label-set)              node-label-set)
671        ((node-property-set)           node-property-set)
672        ((node-interval-property-set)  node-interval-property-set)
673        ((edge-property-set)           edge-property-set)
674        ((edge-interval-property-set)  edge-interval-property-set)
675       
676        (else
677          (interval-digraph:error 'selector ": unknown message " selector " sent to a graph"))))
678   
679    )))
680
681
682(define (digraph-disjoint-union a b) (digraph-union a (digraph-rename ((a 'capacity)) b)))
683
684;;
685;; Naive implementation: randomly choosing edges from NxN possibilities with probability P
686;;
687
688(define (make-random-gnp-digraph name label N P R S loops)
689
690  (if (< N 10) (error 'make-random-gnp-digraph "N is too small" N))
691  (if (not (and (< 0 P) (<= P 1))) (error 'make-random-gnp-digraph "P must be in the interval (0, 1]"))
692
693  (let* ((E     (* N N))
694         (nodes (cis:interval 1 N))
695         (a     (make-digraph name label))
696         (a     ((a 'add-node-interval) nodes)))
697   
698    (let recur ((a a) (s S) (e 0))
699
700      (if (> e E) a
701
702          (let* ((i (inexact->exact (R N P s)))
703                 (j (inexact->exact (R N P s))))
704
705            (if (or (zero? i) (zero? j) (and (= i j) (not loops)) ((a 'has-edge) i j))
706                (recur a s (+ 1 e))
707                (recur ((a 'add-edge) (list i j)) s (+ 1 e))
708                )))
709    )))
710
711
712)
Note: See TracBrowser for help on using the repository browser.