Context Navigation

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.

Download in other formats: