source: project/rgraph/rgraph.scm @ 1

Last change on this file since 1 was 1, checked in by azul, 15 years ago

Import everything.

File size: 63.3 KB
Line 
1(define rgraph-doc-copyright-rgraph #t)
2(define rgraph-doc-copyright-boost #t)
3(define rgraph-doc-usage-imports #t)
4(define rgraph-doc-usage-debugging #t)
5(cond-expand
6  (rgraph-nodebug
7    (define-macro rgraph-debug (lambda (body) '())))
8  ((or rgraph-debug csi)
9   (define-macro rgraph-debug (lambda (body) body)))
10  (else (define-macro rgraph-debug (lambda (body) '()))))
11(define rgraph-doc-adjacency-list #t)
12(define-macro
13  define-adjacency-list
14  (lambda (GTYPE
15           algorithms
16           VTYPE
17           vertex-properties
18           ETYPE
19           edge-properties
20           directed?
21           bidirectional?)
22    (define (pad . args)
23      (string->symbol
24        (apply string-append
25               (map (lambda (a)
26                      (cond ((string? a) a)
27                            ((symbol? a) (symbol->string a))
28                            (else "UNKNOWN_PAD_SYMBOL")))
29                    args))))
30    (define (when-bi . in-args)
31      (if bidirectional? in-args '()))
32    (define (when-bi-or-dir . in-args)
33      (if (or bidirectional? directed?) in-args '()))
34    (let* ((NVP (length vertex-properties))
35           (NEP (length edge-properties))
36           (rec GTYPE)
37           (rec? (gensym))
38           (make-rec (gensym))
39           (rec-vl (gensym))
40           (set-rec-vl! (gensym))
41           (rec-pgetters (gensym))
42           (rec-psetters (gensym))
43           (streamed? (cond-expand (srfi-40 #t) (else #f)))
44           (vertex-set? (pad GTYPE "-vertex-set?"))
45           (edge-set? (pad GTYPE "-edge-set?"))
46           (constructor (pad "make-" GTYPE))
47           (add-edge! (pad GTYPE "-add-edge!"))
48           (remove-edge! (pad GTYPE "-remove-edge!"))
49           (remove-edge2! (pad GTYPE "-remove-edge2!"))
50           (add-directed-edge!
51             (pad "##carp#" GTYPE "-add-directed-edge!"))
52           (remove-directed-edge!
53             (pad "##carp#" GTYPE "-remove-directed-edge!"))
54           (out-edges (pad GTYPE "-out-edges"))
55           (out-edges* (pad GTYPE "-out-edges*"))
56           (out-degree (pad GTYPE "-out-degree"))
57           (in-edges (pad GTYPE "-in-edges"))
58           (in-edges* (pad GTYPE "-in-edges*"))
59           (in-degree (pad GTYPE "-in-degree"))
60           (neighbours (pad GTYPE "-neighbours"))
61           (neighbours* (pad GTYPE "-neighbours*"))
62           (import-vertex-list (pad "define-" (car VTYPE)))
63           (import-edge-list (pad "define-" (car ETYPE)))
64           (vl-constructor (pad "##carp#make-" GTYPE "-vl"))
65           (source (pad GTYPE "-source"))
66           (target (pad GTYPE "-target"))
67           (out-edge-list
68             (pad "##carp#" GTYPE "-out-edge-list"))
69           (in-edge-list
70             (pad "##carp#" GTYPE "-in-edge-list"))
71           (edges (pad "##carp#" GTYPE "-edges"))
72           (edges* (pad "##carp#" GTYPE "-edges*"))
73           (degree (pad "##carp#" GTYPE "-degree")))
74      `(begin
75         (define-record-type
76           ,rec
77           (,make-rec vl pgetters psetters)
78           ,rec?
79           (vl ,rec-vl ,set-rec-vl!)
80           (pgetters ,rec-pgetters)
81           (psetters ,rec-psetters))
82         (,import-edge-list
83          ,GTYPE
84          ,(cdr ETYPE)
85          ,streamed?
86          ,bidirectional?
87          ,edge-properties)
88         (,import-vertex-list
89          ,GTYPE
90          ,(cdr VTYPE)
91          ,streamed?
92          ,bidirectional?
93          ,vertex-properties
94          ,rec-vl)
95         (define-record-printer
96           ,rec
97           (lambda (x p)
98             (fprintf p "Adjacency List~%")
99             (fprintf p "num-vertex-props       ~S~%" ,NVP)
100             (fprintf p "num-edge-props ~S" ,NEP)))
101         (define ,constructor
102           (lambda ()
103             (let* ((pgetters (make-hash-table eq? ,(+ NVP NEP)))
104                    (psetters (make-hash-table eq? ,(+ NVP NEP)))
105                    (rec (,make-rec #f pgetters psetters)))
106               (,set-rec-vl! rec (,vl-constructor rec))
107               ,@(map (lambda (prop)
108                        (define getter (pad GTYPE "-" prop))
109                        (define setter (pad "set-" GTYPE "-" prop "!"))
110                        `(begin
111                           (hash-table-set! pgetters ',prop ,getter)
112                           (hash-table-set! psetters ',prop ,setter)))
113                      (append vertex-properties edge-properties))
114               rec)))
115         (define ,add-edge!
116           (lambda (g u v)
117             (let ((ret (,add-directed-edge! g u (,out-edge-list g u) v)))
118               ,@(when-bi
119                   `(,add-directed-edge! g v (,in-edge-list g v) u))
120               (unless
121                 ,directed?
122                 (,add-directed-edge! g v (,out-edge-list g v) u)
123                 ,@(when-bi
124                     `(,add-directed-edge! g u (,in-edge-list g u) v)))
125               ret)))
126         (define ,remove-edge!
127           (lambda (g e)
128             (,remove-edge2! g (,source g e) (,target g e))))
129         (define ,remove-edge2!
130           (lambda (g u v)
131             (let ((ret (,remove-directed-edge!
132                         g
133                         u
134                         (,out-edge-list g u)
135                         v)))
136               ,@(when-bi
137                   `(,remove-directed-edge!
138                     g
139                     v
140                     (,in-edge-list g v)
141                     u))
142               (unless
143                 ,directed?
144                 (,remove-directed-edge!
145                  g
146                  v
147                  (,out-edge-list g v)
148                  u)
149                 ,@(when-bi
150                     `(,remove-directed-edge!
151                       g
152                       u
153                       (,in-edge-list g u)
154                       v)))
155               ret)))
156         (define ,out-edges
157           (lambda (g u)
158             (,edges g u (,out-edge-list g u) #t)))
159         (define ,out-edges*
160           (lambda (g u)
161             (,edges* g u (,out-edge-list g u) #t)))
162         (define ,out-degree
163           (lambda (g u) (,degree g u (,out-edge-list g u))))
164         ,@(when-bi
165             `(define ,in-edges
166                (lambda (g u)
167                  (,edges g u (,in-edge-list g u) #f)))
168             `(define ,in-edges*
169                (lambda (g u)
170                  (,edges* g u (,in-edge-list g u) #f)))
171             `(define ,in-degree
172                (lambda (g u) (,degree g u (,in-edge-list g u)))))
173         ,@(when-bi-or-dir
174             `(define ,neighbours
175                (lambda (g u)
176                  (append
177                    (map (lambda (e) (cons (,target g e) e))
178                         (,out-edges g u))
179                    (map (lambda (e) (cons (,source g e) e))
180                         (,in-edges g u)))))
181             `(define ,neighbours*
182                (lambda (g u)
183                  (stream-append
184                    (stream-map
185                      (lambda (e) (cons (,target g e) e))
186                      (,out-edges* g u))
187                    (stream-map
188                      (lambda (e) (cons (,source g e) e))
189                      (,in-edges* g u))))))
190         ,@(map (lambda (algorithm)
191                  `(,(pad "import-" algorithm)
192                    ,GTYPE
193                    ,streamed?
194                    (,vertex-set?)
195                    (,edge-set?)
196                    ,directed?
197                    ,bidirectional?))
198                algorithms)))))
199(define rgraph-doc-vl-vector #t)
200(define-macro
201  define-vl-vector
202  (lambda (GTYPE
203           VARGS
204           streamed?
205           bidirectional?
206           vertex-properties
207           get-vl)
208    (define (pad . args)
209      (string->symbol
210        (apply string-append
211               (map (lambda (a)
212                      (cond ((string? a) a)
213                            ((symbol? a) (symbol->string a))
214                            (else "UNKNOWN_PAD_SYMBOL")))
215                    args))))
216    (define plus (if streamed? "*" ""))
217    (define prefix-plus (if streamed? "stream-" ""))
218    (define (when-bi . in-args)
219      (if bidirectional? in-args '()))
220    (define (unless-bi . in-args)
221      (if bidirectional? '() in-args))
222    (let* ((for-each+ (pad prefix-plus "for-each"))
223           (map+ (pad prefix-plus "map"))
224           (NP (length vertex-properties))
225           (vl (pad GTYPE "-vertex-list"))
226           (vl? (gensym))
227           (make-vl (gensym))
228           (vl-num (gensym))
229           (set-vl-num! (gensym))
230           (vl-vec (gensym))
231           (set-vl-vec! (gensym))
232           (rec (pad GTYPE "-vertex"))
233           (rec? (gensym))
234           (make-rec (gensym))
235           (rec-out-edge-l (gensym))
236           (set-rec-out-edge-l! (gensym))
237           (rec-in-edge-l (gensym))
238           (set-rec-in-edge-l! (gensym))
239           (rec-props (gensym))
240           (set-rec-props! (gensym))
241           (vertex-set? (pad GTYPE "-vertex-set?"))
242           (constructor (pad "##carp#make-" GTYPE "-vl"))
243           (check-valid (gensym))
244           (vertex-index (pad GTYPE "-vertex-index"))
245           (add-vertex! (pad GTYPE "-add-vertex!"))
246           (remove-vertex! (pad GTYPE "-remove-vertex!"))
247           (vertex (pad GTYPE "-vertex"))
248           (vertex-eq? (pad GTYPE "-vertex-eq?"))
249           (out-edge-list
250             (pad "##carp#" GTYPE "-out-edge-list"))
251           (in-edge-list
252             (pad "##carp#" GTYPE "-in-edge-list"))
253           (num-vertices (pad GTYPE "-num-vertices"))
254           (vertices (pad GTYPE "-vertices"))
255           (vertices* (pad GTYPE "-vertices*"))
256           (clear! (pad GTYPE "-clear!"))
257           (el-constructor (pad "##carp#make-" GTYPE "-el"))
258           (edge (pad GTYPE "-edge"))
259           (in-edges+ (pad GTYPE "-in-edges" plus))
260           (out-edges+ (pad GTYPE "-out-edges" plus))
261           (remove-edge! (pad GTYPE "-remove-edge!"))
262           (transform-vertices!
263             (pad "##carp#" GTYPE "-transform-vertices!")))
264      `(begin
265         (define-macro ,vertex-set? (lambda () `#f))
266         (define-record-type
267           ,vl
268           (,make-vl num vec)
269           ,vl?
270           (num ,vl-num ,set-vl-num!)
271           (vec ,vl-vec ,set-vl-vec!))
272         (define-record-printer
273           ,vl
274           (lambda (x p)
275             (fprintf p "Vertex List vl-vector~%")
276             (fprintf p "size   ~S" (,vl-num x))))
277         (define-record-type
278           ,rec
279           (,make-rec
280            out-edge-l
281            ,@(when-bi 'in-edge-l)
282            props)
283           ,rec?
284           (out-edge-l ,rec-out-edge-l ,set-rec-out-edge-l!)
285           ,@(when-bi
286               `(in-edge-l ,rec-in-edge-l ,set-rec-in-edge-l!))
287           (props ,rec-props ,set-rec-props!))
288         (define-record-printer
289           ,rec
290           (lambda (x p) (fprintf p "Vertex ~S" x)))
291         (define ,constructor
292           (lambda (g) (,make-vl 0 (make-vector 0))))
293         (define-macro
294           ,check-valid
295           (lambda (u num)
296             `(rgraph-debug
297                (when (or (not (integer? ,u)) (< ,u 0) (>= ,u ,num))
298                      (error "Invalid vl-vector vertex descriptor")))))
299         (define ,vertex-index
300           (lambda (g v)
301             (,check-valid v (,vl-num (,get-vl g)))
302             v))
303         ,@(let ((index -1))
304             (map (lambda (prop)
305                    (let ((getter (pad GTYPE "-" prop))
306                          (setter! (pad "set-" GTYPE "-" prop "!"))
307                          (pmap (pad GTYPE "-" prop "-map")))
308                      (set! index (add1 index))
309                      `(begin
310                         (define ,getter
311                           (lambda (g v)
312                             (,check-valid v (,vl-num (,get-vl g)))
313                             (vector-ref
314                               (,rec-props
315                                (vector-ref (,vl-vec (,get-vl g)) v))
316                               ,index)))
317                         (define ,setter!
318                           (lambda (g v p)
319                             (,check-valid v (,vl-num (,get-vl g)))
320                             (vector-set!
321                               (,rec-props
322                                (vector-ref (,vl-vec (,get-vl g)) v))
323                               ,index
324                               p)))
325                         (define ,pmap (cons ,getter ,setter!)))))
326                  vertex-properties))
327         (define ,add-vertex!
328           (lambda (g . ignored)
329             (let* ((vl (,get-vl g))
330                    (num (,vl-num vl))
331                    (vec (,vl-vec vl))
332                    (length (vector-length vec))
333                    (rec (,make-rec
334                          (,el-constructor g)
335                          ,@(when-bi `(,el-constructor g))
336                          (make-vector ,NP #f))))
337               (cond ((< num length))
338                     ((zero? length) (set! vec (make-vector 1 #f)))
339                     (else
340                      (set! vec
341                        (vector-resize
342                          vec
343                          (max 2 (quotient (* 17 length) 10))
344                          #f))))
345               (vector-set! vec num rec)
346               (,set-vl-vec! vl vec)
347               (,set-vl-num! vl (add1 num))
348               num)))
349         (define ,remove-vertex!
350           (lambda (g u)
351             (let* ((vl (,get-vl g))
352                    (num (,vl-num vl))
353                    (num-- (sub1 num))
354                    (vec (,vl-vec vl))
355                    (length (vector-length vec))
356                    (down (quotient (* 10 length) 17)))
357               (,check-valid u num)
358               (,for-each+
359                (lambda (u^v) (,remove-edge! g u^v))
360                (,out-edges+ g u))
361               ,@(when-bi
362                   `(,for-each+
363                     (lambda (v^u) (,remove-edge! g v^u))
364                     (,in-edges+ g u)))
365               ,@(unless-bi
366                   `(do ((v 0 (add1 v)))
367                        ((>= v num))
368                      (let ((v^u (,edge g v u)))
369                        (when v^u (,remove-edge! g v^u)))))
370               (cond ((< num down)
371                      (set! vec (vector-resize vec down))
372                      (,set-vl-vec! vl vec)))
373               (let loop ((n u))
374                 (cond ((> n num--))
375                       ((= n num--) (vector-set! vec n #f))
376                       (else
377                        (vector-set! vec n (vector-ref vec (add1 n)))
378                        (loop (add1 n)))))
379               (,set-vl-num! vl (sub1 num))
380               (do ((i 0 (add1 i)))
381                   ((>= i num--))
382                 (,transform-vertices!
383                  (lambda (v) (if (> v u) (sub1 v) v))
384                  g
385                  i)))))
386         (define ,vertex
387           (lambda (g n)
388             (let* ((vl (,get-vl g)) (num (,vl-num vl)))
389               (,check-valid n num)
390               n)))
391         (define ,vertex-eq?
392           (lambda (g u v)
393             (,check-valid u (,vl-num (,get-vl g)))
394             (,check-valid v (,vl-num (,get-vl g)))
395             (= u v)))
396         (define ,out-edge-list
397           (lambda (g u)
398             (let* ((vl (,get-vl g))
399                    (num (,vl-num vl))
400                    (vec (,vl-vec vl)))
401               (,check-valid u num)
402               (,rec-out-edge-l (vector-ref vec u)))))
403         ,@(when-bi
404             `(define ,in-edge-list
405                (lambda (g u)
406                  (let* ((vl (,get-vl g))
407                         (num (,vl-num vl))
408                         (vec (,vl-vec vl)))
409                    (,check-valid u num)
410                    (,rec-in-edge-l (vector-ref vec u))))))
411         (define ,vertices
412           (lambda (g)
413             (let* ((vl (,get-vl g)) (num (,vl-num vl)))
414               (let iter ((i 0))
415                 (cond ((= i num) '())
416                       (else (cons i (iter (add1 i)))))))))
417         (define ,vertices*
418           (lambda (g)
419             (let* ((vl (,get-vl g)) (num (,vl-num vl)))
420               (let iter ((i 0))
421                 (stream-delay
422                   (cond ((= i num) stream-null)
423                         (else (stream-cons i (iter (add1 i))))))))))
424         (define ,num-vertices
425           (lambda (g)
426             (let* ((vl (,get-vl g)) (num (,vl-num vl))) num)))
427         (define ,clear!
428           (lambda (g)
429             (let ((vl (,get-vl g)))
430               (,set-vl-num! vl 0)
431               (,set-vl-vec! vl (make-vector 0)))))))))
432(define rgraph-doc-vl-hash #t)
433(define-macro
434  define-vl-hash
435  (lambda (GTYPE
436           VARGS
437           streamed?
438           bidirectional?
439           vertex-properties
440           get-vl)
441    (define (pad . args)
442      (string->symbol
443        (apply string-append
444               (map (lambda (a)
445                      (cond ((string? a) a)
446                            ((symbol? a) (symbol->string a))
447                            (else "UNKNOWN_PAD_SYMBOL")))
448                    args))))
449    (define plus (if streamed? "*" ""))
450    (define prefix-plus (if streamed? "stream-" ""))
451    (define (when-bi . in-args)
452      (if bidirectional? in-args '()))
453    (define (unless-bi . in-args)
454      (if bidirectional? '() in-args))
455    (let* ((for-each+ (pad prefix-plus "for-each"))
456           (map+ (pad prefix-plus "map"))
457           (NP (length vertex-properties))
458           (vl (pad GTYPE "-vertex-list"))
459           (vl? (gensym))
460           (make-vl (gensym))
461           (vl-table (gensym))
462           (set-vl-table! (gensym))
463           (vl-max-index (gensym))
464           (set-vl-max-index! (gensym))
465           (rec (pad GTYPE "-vertex"))
466           (rec? (gensym))
467           (make-rec (gensym))
468           (rec-index (gensym))
469           (set-rec-index! (gensym))
470           (rec-out-edge-l (gensym))
471           (set-rec-out-edge-l! (gensym))
472           (rec-in-edge-l (gensym))
473           (set-rec-in-edge-l! (gensym))
474           (rec-props (gensym))
475           (set-rec-props! (gensym))
476           (vertex-set? (pad GTYPE "-vertex-set?"))
477           (constructor (pad "##carp#make-" GTYPE "-vl"))
478           (check-valid (gensym))
479           (vertex-index (pad GTYPE "-vertex-index"))
480           (add-vertex! (pad GTYPE "-add-vertex!"))
481           (remove-vertex! (pad GTYPE "-remove-vertex!"))
482           (vertex (pad GTYPE "-vertex"))
483           (vertex-eq? (pad GTYPE "-vertex-eq?"))
484           (out-edge-list
485             (pad "##carp#" GTYPE "-out-edge-list"))
486           (in-edge-list
487             (pad "##carp#" GTYPE "-in-edge-list"))
488           (num-vertices (pad GTYPE "-num-vertices"))
489           (vertices (pad GTYPE "-vertices"))
490           (vertices* (pad GTYPE "-vertices*"))
491           (clear! (pad GTYPE "-clear!"))
492           (el-constructor (pad "##carp#make-" GTYPE "-el"))
493           (edge (pad GTYPE "-edge"))
494           (in-edges+ (pad GTYPE "-in-edges" plus))
495           (out-edges+ (pad GTYPE "-out-edges" plus))
496           (remove-edge! (pad GTYPE "-remove-edge!"))
497           (transform-vertices!
498             (pad "##carp#" GTYPE "-transform-vertices!")))
499      `(begin
500         (define-macro ,vertex-set? (lambda () `#t))
501         (define-record-type
502           ,vl
503           (,make-vl table max-index)
504           ,vl?
505           (table ,vl-table ,set-vl-table!)
506           (max-index ,vl-max-index ,set-vl-max-index!))
507         (define-record-printer
508           ,vl
509           (lambda (x p)
510             (fprintf p "Vertex List vl-hash~%")
511             (fprintf
512               p
513               "size    ~S"
514               (hash-table-size (,vl-table x)))))
515         (define-record-type
516           ,rec
517           (,make-rec
518            index
519            out-edge-l
520            ,@(when-bi 'in-edge-l)
521            props)
522           ,rec?
523           (index ,rec-index ,set-rec-index!)
524           (out-edge-l ,rec-out-edge-l ,set-rec-out-edge-l!)
525           ,@(when-bi
526               `(in-edge-l ,rec-in-edge-l ,set-rec-in-edge-l!))
527           (props ,rec-props ,set-rec-props!))
528         (define-record-printer
529           ,rec
530           (lambda (x p) (fprintf p "Vertex ~S" x)))
531         (define ,constructor
532           (lambda (g)
533             (,make-vl (make-hash-table ,@VARGS) 0)))
534         (define-macro ,check-valid (lambda (u) #t))
535         (define ,vertex-index
536           (lambda (g v)
537             (let* ((vl (,get-vl g))
538                    (table (,vl-table vl))
539                    (rec (hash-table-ref table v)))
540               (,rec-index rec))
541             v))
542         ,@(let ((index -1))
543             (map (lambda (prop)
544                    (let ((getter (pad GTYPE "-" prop))
545                          (setter! (pad "set-" GTYPE "-" prop "!"))
546                          (pmap (pad GTYPE "-" prop "-map")))
547                      (set! index (add1 index))
548                      `(begin
549                         (define ,getter
550                           (lambda (g v)
551                             (,check-valid v)
552                             (vector-ref
553                               (,rec-props
554                                (hash-table-ref (,vl-table (,get-vl g)) v))
555                               ,index)))
556                         (define ,setter!
557                           (lambda (g v p)
558                             (,check-valid v)
559                             (vector-set!
560                               (,rec-props
561                                (hash-table-ref (,vl-table (,get-vl g)) v))
562                               ,index
563                               p)))
564                         (define ,pmap (cons ,getter ,setter!)))))
565                  vertex-properties))
566         (define ,add-vertex!
567           (lambda (g key . ignored)
568             (let* ((vl (,get-vl g))
569                    (table (,vl-table vl))
570                    (rec (hash-table-ref table key)))
571               (unless
572                 rec
573                 (let ((index (,vl-max-index vl)))
574                   (hash-table-set!
575                     table
576                     key
577                     (,make-rec
578                      index
579                      (,el-constructor g)
580                      ,@(when-bi `(,el-constructor g))
581                      (make-vector ,NP #f)))
582                   (,set-vl-max-index! vl (add1 index))))
583               key)))
584         (define ,remove-vertex!
585           (lambda (g u)
586             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
587               (,check-valid u)
588               (,for-each+
589                (lambda (u^v) (,remove-edge! g u^v))
590                (,out-edges+ g u))
591               ,@(when-bi
592                   `(,for-each+
593                     (lambda (v^u) (,remove-edge! g v^u))
594                     (,in-edges+ g u)))
595               ,@(unless-bi
596                   `(do ((v 0 (add1 v)))
597                        ((>= v num))
598                      (let ((v^u (,edge g v u)))
599                        (when v^u (,remove-edge! g v^u)))))
600               (hash-table-remove! table u))))
601         (define ,vertex-eq?
602           (lambda (g u v)
603             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
604               (,check-valid u)
605               (,check-valid v)
606               (,(if (pair? VARGS) (car VARGS) 'eq?) u v))))
607         (define ,out-edge-list
608           (lambda (g u)
609             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
610               (,check-valid u)
611               (,rec-out-edge-l (hash-table-ref table u)))))
612         ,@(when-bi
613             `(define ,in-edge-list
614                (lambda (g u)
615                  (let* ((vl (,get-vl g)) (table (,vl-table vl)))
616                    (,check-valid u)
617                    (,rec-in-edge-l (hash-table-ref table u))))))
618         (define ,vertices
619           (lambda (g)
620             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
621               (hash-table-map (lambda (k v) k) table))))
622         (define ,vertices*
623           (lambda (g)
624             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
625               (stream-map
626                 (lambda (kv) (car kv))
627                 (hash-table->stream table)))))
628         (define ,num-vertices
629           (lambda (g)
630             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
631               (hash-table-size table))))
632         (define ,clear!
633           (lambda (g)
634             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
635               (##sys#setslot table 1 (make-vector (##sys#size (##sys#slot table 1)) '())))))))))
636(define rgraph-doc-el-slist #t)
637(define-macro
638  define-el-slist
639  (lambda (GTYPE
640           VARGS
641           streamed?
642           bidirectional?
643           edge-properties)
644    (define (pad . args)
645      (string->symbol
646        (apply string-append
647               (map (lambda (a)
648                      (cond ((string? a) a)
649                            ((symbol? a) (symbol->string a))
650                            (else "UNKNOWN_PAD_SYMBOL")))
651                    args))))
652    (define (when-bi . in-args)
653      (if bidirectional? in-args '()))
654    (let* ((NP (length edge-properties))
655           (el (pad GTYPE "-edge-list"))
656           (el? (gensym))
657           (make-el (gensym))
658           (el-tlist (gensym))
659           (set-el-tlist! (gensym))
660           (el-tnum (gensym))
661           (set-el-tnum! (gensym))
662           (rec (pad GTYPE "-edge"))
663           (rec? (gensym))
664           (make-rec (gensym))
665           (rec-target (gensym))
666           (set-rec-target! (gensym))
667           (rec-props (gensym))
668           (set-rec-props! (gensym))
669           (edge-set? (pad GTYPE "-edge-set?"))
670           (constructor (pad "##carp#make-" GTYPE "-el"))
671           (add-directed-edge!
672             (pad "##carp#" GTYPE "-add-directed-edge!"))
673           (remove-directed-edge!
674             (pad "##carp#" GTYPE "-remove-directed-edge!"))
675           (edge (pad GTYPE "-edge"))
676           (source (pad GTYPE "-source"))
677           (target (pad GTYPE "-target"))
678           (edges (pad "##carp#" GTYPE "-edges"))
679           (edges* (pad "##carp#" GTYPE "-edges*"))
680           (edge-at (pad GTYPE "-edge-at"))
681           (degree (pad "##carp#" GTYPE "-degree"))
682           (transform-vertices!
683             (pad "##carp#" GTYPE "-transform-vertices!"))
684           (out-edge-list
685             (pad "##carp#" GTYPE "-out-edge-list"))
686           (in-edge-list
687             (pad "##carp#" GTYPE "-in-edge-list"))
688           (vertex-eq? (pad GTYPE "-vertex-eq?")))
689      `(begin
690         (define-macro ,edge-set? (lambda () `#f))
691         (define-record-type
692           ,el
693           (,make-el tlist tnum)
694           ,el?
695           (tlist ,el-tlist ,set-el-tlist!)
696           (tnum ,el-tnum ,set-el-tnum!))
697         (define-record-printer
698           ,el
699           (lambda (x p)
700             (fprintf p "Edge List el-slist~%")
701             (fprintf p "degree ~S" (,el-tnum x))))
702         (define-record-type
703           ,rec
704           (,make-rec target props)
705           ,rec?
706           (target ,rec-target ,set-rec-target!)
707           (props ,rec-props ,set-rec-props!))
708         (define-record-printer
709           ,rec
710           (lambda (x p)
711             (fprintf
712               p
713               "Edge | target vertex    ~S"
714               (,rec-target x))))
715         (define ,constructor
716           (lambda (g) (,make-el '() 0)))
717         ,@(let ((index -1))
718             (map (lambda (prop)
719                    (let ((getter (pad GTYPE "-" prop))
720                          (setter! (pad "set-" GTYPE "-" prop "!"))
721                          (pmap (pad GTYPE "-" prop "-map")))
722                      (set! index (add1 index))
723                      `(begin
724                         (define ,getter
725                           (lambda (g e)
726                             (vector-ref (,rec-props (cdr e)) ,index)))
727                         (define ,setter!
728                           (lambda (g e p)
729                             (vector-set! (,rec-props (cdr e)) ,index p)))
730                         (define ,pmap (cons ,getter ,setter!)))))
731                  edge-properties))
732         (define ,add-directed-edge!
733           (lambda (g u u-el v)
734             (let* ((u-tlist (,el-tlist u-el))
735                    (v-rec (,make-rec v (make-vector ,NP #f))))
736               (set! u-tlist (cons v-rec u-tlist))
737               (,set-el-tlist! u-el u-tlist)
738               (,set-el-tnum! u-el (add1 (,el-tnum u-el)))
739               (cons u v-rec))))
740         (define ,remove-directed-edge!
741           (lambda (g u u-el v)
742             (let* ((u-tlist (,el-tlist u-el)))
743               (let find ((tlist u-tlist) (predecessor #f))
744                 (cond ((null? tlist)
745                        (error "Could not remove directed edge"
746                               g
747                               u
748                               u-el
749                               v))
750                       ((,vertex-eq? g v (,rec-target (car tlist)))
751                        (cond (predecessor (set-cdr! predecessor (cdr tlist)))
752                              (else (,set-el-tlist! u-el (cdr tlist))))
753                        (,set-el-tnum! u-el (sub1 (,el-tnum u-el)))
754                        #t)
755                       (else (find (cdr tlist) tlist)))))))
756         (define ,edge
757           (lambda (g u v)
758             (let* ((u-el (,out-edge-list g u))
759                    (u-tlist (,el-tlist u-el)))
760               (let find ((tlist u-tlist))
761                 (cond ((null? tlist) #f)
762                       ((,vertex-eq? g v (,rec-target (car tlist)))
763                        (cons u (car tlist)))
764                       (else (find (cdr tlist))))))))
765         (define ,source (lambda (g e) (car e)))
766         (define ,target
767           (lambda (g e) (,rec-target (cdr e))))
768         (define ,edges
769           (lambda (g u u-el out?)
770             (map (lambda (v-rec)
771                    (if out?
772                      (cons u v-rec)
773                      (,edge g (,rec-target v-rec) u)))
774                  (,el-tlist u-el))))
775         (define ,edges*
776           (lambda (g u u-el out?)
777             (stream-map
778               (lambda (v-rec)
779                 (if out?
780                   (cons u v-rec)
781                   (,edge g (,rec-target v-rec) u)))
782               (list->stream (,el-tlist u-el)))))
783         (define ,edge-at
784           (lambda (g u n)
785             (let* ((u-el (,out-edge-list g u))
786                    (u-tlist (,el-tlist u-el))
787                    (u-tnum (,el-tnum u-el))
788                    (where (- u-tnum n 1)))
789               (when (< where)
790                     (error "Invalid el-slist edge index"))
791               (cons u (list-ref u-tlist where)))))
792         (define ,degree
793           (lambda (g u u-el) (,el-tnum u-el)))
794         (define ,transform-vertices!
795           (lambda (proc g u)
796             (define (x v-rec)
797               (,set-rec-target!
798                v-rec
799                (proc (,rec-target v-rec))))
800             (for-each x (,el-tlist (,out-edge-list g u)))
801             ,@(when-bi
802                 `(for-each x (,el-tlist (,in-edge-list g u))))))))))
803(define rgraph-doc-el-hash #t)
804(define-macro
805  define-el-hash
806  (lambda (GTYPE
807           VARGS
808           streamed?
809           bidirectional?
810           edge-properties)
811    (define (pad . args)
812      (string->symbol
813        (apply string-append
814               (map (lambda (a)
815                      (cond ((string? a) a)
816                            ((symbol? a) (symbol->string a))
817                            (else "UNKNOWN_PAD_SYMBOL")))
818                    args))))
819    (define (when-bi . in-args)
820      (if bidirectional? in-args '()))
821    (let* ((NP (length edge-properties))
822           (el (pad GTYPE "-edge-list"))
823           (el? (gensym))
824           (make-el (gensym))
825           (el-thash (gensym))
826           (set-el-thash! (gensym))
827           (rec (pad GTYPE "-edge"))
828           (rec? (gensym))
829           (make-rec (gensym))
830           (rec-target (gensym))
831           (set-rec-target! (gensym))
832           (rec-props (gensym))
833           (set-rec-props! (gensym))
834           (pre-constructor
835             (pad "##carp#make-" GTYPE "-pre-el"))
836           (edge-set? (pad GTYPE "-edge-set?"))
837           (constructor (pad "##carp#make-" GTYPE "-el"))
838           (add-directed-edge!
839             (pad "##carp#" GTYPE "-add-directed-edge!"))
840           (remove-directed-edge!
841             (pad "##carp#" GTYPE "-remove-directed-edge!"))
842           (edge (pad GTYPE "-edge"))
843           (source (pad GTYPE "-source"))
844           (target (pad GTYPE "-target"))
845           (edges (pad "##carp#" GTYPE "-edges"))
846           (edges* (pad "##carp#" GTYPE "-edges*"))
847           (degree (pad "##carp#" GTYPE "-degree"))
848           (transform-vertices!
849             (pad "##carp#" GTYPE "-transform-vertices!"))
850           (out-edge-list
851             (pad "##carp#" GTYPE "-out-edge-list"))
852           (in-edge-list
853             (pad "##carp#" GTYPE "-in-edge-list"))
854           (vertex-eq? (pad GTYPE "-vertex-eq?")))
855      `(begin
856         (define-macro ,edge-set? (lambda () `#t))
857         (define-record-type
858           ,el
859           (,make-el thash)
860           ,el?
861           (thash ,el-thash ,set-el-thash!))
862         (define-record-printer
863           ,el
864           (lambda (x p)
865             (fprintf p "Edge List el-hash~%")
866             (fprintf
867               p
868               "degree  ~S"
869               (hash-table-size (,el-thash x)))))
870         (define-record-type
871           ,rec
872           (,make-rec target props)
873           ,rec?
874           (target ,rec-target ,set-rec-target!)
875           (props ,rec-props ,set-rec-props!))
876         (define-record-printer
877           ,rec
878           (lambda (x p)
879             (fprintf
880               p
881               "Edge | target vertex    ~S"
882               (,rec-target x))))
883         (define ,pre-constructor
884           (lambda (g)
885             (make-hash-table
886               (lambda (a b) (,vertex-eq? g a b)))))
887         (define ,constructor
888           (lambda (g) (,make-el (,pre-constructor g))))
889         ,@(let ((index -1))
890             (map (lambda (prop)
891                    (let ((getter (pad GTYPE "-" prop))
892                          (setter! (pad "set-" GTYPE "-" prop "!"))
893                          (pmap (pad GTYPE "-" prop "-map")))
894                      (set! index (add1 index))
895                      `(begin
896                         (define ,getter
897                           (lambda (g e)
898                             (vector-ref (,rec-props (cdr e)) ,index)))
899                         (define ,setter!
900                           (lambda (g e p)
901                             (vector-set! (,rec-props (cdr e)) ,index p)))
902                         (define ,pmap (cons ,getter ,setter!)))))
903                  edge-properties))
904         (define ,add-directed-edge!
905           (lambda (g u u-el v)
906             (let* ((u-thash (,el-thash u-el))
907                    (v-rec (hash-table-ref/default u-thash v #f)))
908               (unless
909                 v-rec
910                 (set! v-rec (,make-rec v (make-vector ,NP #f)))
911                 (hash-table-set! u-thash v v-rec))
912               (cons u v-rec))))
913         (define ,remove-directed-edge!
914           (lambda (g u u-el v)
915             (let* ((u-thash (,el-thash u-el)))
916               (unless
917                 (hash-table-remove! u-thash v)
918                 (error "Could not remove directed edge"
919                        g
920                        u
921                        u-el
922                        v)))))
923         (define ,edge
924           (lambda (g u v)
925             (let* ((u-el (,out-edge-list g u))
926                    (u-thash (,el-thash u-el))
927                    (v-rec (hash-table-ref/default u-thash v #f)))
928               (and v-rec (cons u v-rec)))))
929         (define ,source (lambda (g e) (car e)))
930         (define ,target
931           (lambda (g e) (,rec-target (cdr e))))
932         (define ,edges
933           (lambda (g u u-el out?)
934             (hash-table-map
935               (lambda (v v-rec)
936                 (if out? (cons u v-rec) (,edge g v u)))
937               (,el-thash u-el))))
938         (define ,edges*
939           (lambda (g u u-el out?)
940             (stream-map
941               (lambda (v.v-rec)
942                 (if out?
943                   (cons u (cdr v.v-rec))
944                   (,edge g (car v.v-rec) u)))
945               (hash-table->stream (,el-thash u-el)))))
946         (define ,degree
947           (lambda (g u u-el)
948             (hash-table-size (,el-thash u-el))))
949         (define ,transform-vertices!
950           (lambda (proc g u)
951             (define new-out-thash (,pre-constructor g))
952             ,@(when-bi
953                 `(define new-in-thash (,pre-constructor g)))
954             (define (x! new-thash v v-rec)
955               (,set-rec-target!
956                v-rec
957                (proc (,rec-target v-rec)))
958               (hash-table-set! new-thash (proc v) v-rec))
959             (hash-table-walk
960               (lambda (v v-rec) (x! new-out-thash v v-rec))
961               (,el-thash (,out-edge-list g u)))
962             (,set-el-thash!
963              (,out-edge-list g u)
964              new-out-thash)
965             ,@(when-bi
966                 `(hash-table-walk
967                    (lambda (v v-rec) (x! new-in-thash v v-rec))
968                    (,el-thash (,in-edge-list g u)))
969                 `(,set-el-thash! (,in-edge-list g u) new-in-thash))))))))
970(define rgraph-doc-visitors #t)
971(define rgraph-doc-properties #t)
972(define rgraph-doc-let-rgraph #t)
973(define-macro
974  let-rgraph
975  (lambda (GTYPE . rest)
976    (define plus
977      (cond-expand (srfi-40 "*") (else "")))
978    (define prefix-plus
979      (cond-expand (srfi-40 "stream-") (else "")))
980    (define (pad . args)
981      (string->symbol
982        (apply string-append
983               (map (lambda (a)
984                      (cond ((string? a) a)
985                            ((symbol? a) (symbol->string a))
986                            (else "UNKNOWN_PAD_SYMBOL")))
987                    args))))
988    (let ((for-each+ (pad prefix-plus "for-each"))
989          (map+ (pad prefix-plus "map"))
990          (make-graph (pad "make-" GTYPE))
991          (add-edge! (pad GTYPE "-add-edge!"))
992          (remove-edge! (pad GTYPE "-remove-edge!"))
993          (remove-edge2! (pad GTYPE "-remove-edge2!"))
994          (out-edges (pad GTYPE "-out-edges"))
995          (out-edges* (pad GTYPE "-out-edges*"))
996          (out-edges+ (pad GTYPE "-out-edges" plus))
997          (out-degree (pad GTYPE "-out-degree"))
998          (in-edges (pad GTYPE "-in-edges"))
999          (in-edges* (pad GTYPE "-in-edges*"))
1000          (in-edges+ (pad GTYPE "-in-edges" plus))
1001          (in-degree (pad GTYPE "-in-degree"))
1002          (vertex-index (pad GTYPE "-vertex-index"))
1003          (add-vertex! (pad GTYPE "-add-vertex!"))
1004          (remove-vertex! (pad GTYPE "-remove-vertex!"))
1005          (vertex (pad GTYPE "-vertex"))
1006          (vertex-eq? (pad GTYPE "-vertex-eq?"))
1007          (num-vertices (pad GTYPE "-num-vertices"))
1008          (vertices (pad GTYPE "-vertices"))
1009          (vertices* (pad GTYPE "-vertices*"))
1010          (vertices+ (pad GTYPE "-vertices" plus))
1011          (clear! (pad GTYPE "-clear!"))
1012          (edge (pad GTYPE "-edge"))
1013          (source (pad GTYPE "-source"))
1014          (target (pad GTYPE "-target"))
1015          (edge-at (pad GTYPE "-edge-at")))
1016      `(let ((for-each+ ,for-each+)
1017             (map+ ,map+)
1018             (make-graph ,make-graph)
1019             (add-edge! ,add-edge!)
1020             (remove-edge! ,remove-edge!)
1021             (remove-edge2! ,remove-edge2!)
1022             (out-edges ,out-edges)
1023             (out-edges* ,out-edges*)
1024             (out-edges+ ,out-edges+)
1025             (out-degree ,out-degree)
1026             (in-edges ,in-edges)
1027             (in-edges* ,in-edges*)
1028             (in-edges+ ,in-edges+)
1029             (in-degree ,in-degree)
1030             (vertex-index ,vertex-index)
1031             (add-vertex! ,add-vertex!)
1032             (remove-vertex! ,remove-vertex!)
1033             (vertex ,vertex)
1034             (vertex-eq? ,vertex-eq?)
1035             (num-vertices ,num-vertices)
1036             (vertices ,vertices)
1037             (vertices* ,vertices*)
1038             (vertices+ ,vertices+)
1039             (clear! ,clear!)
1040             (edge ,edge)
1041             (source ,source)
1042             (target ,target)
1043             (edge-at ,edge-at))
1044         ,@rest))))
1045(define rgraph-doc-fill-graph! #t)
1046(define-macro
1047  (import-fill-graph!
1048    GTYPE
1049    streamed?
1050    vertex-set?
1051    edge-set?
1052    directed?
1053    bidirectional?)
1054  (define (pad . args)
1055    (string->symbol
1056      (apply string-append
1057             (map (lambda (a)
1058                    (cond ((string? a) a)
1059                          ((symbol? a) (symbol->string a))
1060                          (else "UNKNOWN_PAD_SYMBOL")))
1061                  args))))
1062  (define (when-bi . in-args)
1063    (if bidirectional? in-args '()))
1064  (let ((algorithm (pad GTYPE "-fill-graph!"))
1065        (vertex-eq? (pad GTYPE "-vertex-eq?"))
1066        (add-vertex! (pad GTYPE "-add-vertex!"))
1067        (add-edge! (pad GTYPE "-add-edge!")))
1068    `(define ,algorithm
1069       (lambda (g edges set-vertex-name!)
1070         (define h (make-hash-table))
1071         (for-each
1072           (lambda (edge)
1073             (let* ((v1 (car edge))
1074                    (v2 (cdr edge))
1075                    (vertex1 (hash-table-ref/default h v1 #f))
1076                    (vertex2 (hash-table-ref/default h v2 #f)))
1077               (cond ((not vertex1)
1078                      (set! vertex1 (,add-vertex! g v1))
1079                      (when set-vertex-name!
1080                            (set-vertex-name! g vertex1 v1))
1081                      (hash-table-set! h v1 vertex1)))
1082               (cond ((not vertex2)
1083                      (set! vertex2 (,add-vertex! g v2))
1084                      (when set-vertex-name!
1085                            (set-vertex-name! g vertex2 v2))
1086                      (hash-table-set! h v2 vertex2)))
1087               (,add-edge! g vertex1 vertex2)))
1088           edges)
1089         g))))
1090(define rgraph-doc-dfs #t)
1091(define rgraph-doc-dfs #t)
1092(define-macro
1093  (import-depth-first-search
1094    GTYPE
1095    streamed?
1096    vertex-set?
1097    edge-set?
1098    directed?
1099    bidirectional?)
1100  (define (pad . args)
1101    (string->symbol
1102      (apply string-append
1103             (map (lambda (a)
1104                    (cond ((string? a) a)
1105                          ((symbol? a) (symbol->string a))
1106                          (else "UNKNOWN_PAD_SYMBOL")))
1107                  args))))
1108  (define (when-bi . in-args)
1109    (if bidirectional? in-args '()))
1110  `(begin
1111     ,@(map (lambda (streamed?)
1112              (define plus (if streamed? "*" ""))
1113              (define prefix-plus (if streamed? "stream-" ""))
1114              (let ((for-each+ (pad prefix-plus "for-each"))
1115                    (map+ (pad prefix-plus "map"))
1116                    (algorithm+
1117                      (pad GTYPE "-depth-first-search" plus))
1118                    (vertex-eq? (pad GTYPE "-vertex-eq?"))
1119                    (target (pad GTYPE "-target"))
1120                    (num-vertices (pad GTYPE "-num-vertices"))
1121                    (vertices+ (pad GTYPE "-vertices" plus))
1122                    (out-edges+ (pad GTYPE "-out-edges" plus)))
1123                `(define ,algorithm+
1124                   (lambda (g dfs-visitor color-map starting-vertex)
1125                     (let* ((dfs-visitor
1126                              (if dfs-visitor dfs-visitor (null-dfs-visitor)))
1127                            (color-map
1128                              (or color-map
1129                                  (prop-external-hash
1130                                    (lambda (v1 v2) (,vertex-eq? g v1 v2))
1131                                    (,num-vertices g))))
1132                            (color (car color-map))
1133                            (set-color! (cdr color-map))
1134                            (init (dfs-visitor-init dfs-visitor))
1135                            (start (dfs-visitor-start dfs-visitor))
1136                            (discover (dfs-visitor-discover dfs-visitor))
1137                            (examine (dfs-visitor-examine dfs-visitor))
1138                            (tree-edge (dfs-visitor-tree-edge dfs-visitor))
1139                            (back-edge (dfs-visitor-back-edge dfs-visitor))
1140                            (forward-or-cross-edge
1141                              (dfs-visitor-forward-or-cross-edge dfs-visitor))
1142                            (finish (dfs-visitor-finish dfs-visitor)))
1143                       (define (depth-first-visit u)
1144                         (set-color! g u 'GRAY)
1145                         (when discover (discover g u))
1146                         (,for-each+
1147                          (lambda (u->v)
1148                            (call/cc
1149                              (lambda (escape)
1150                                (let ((v (,target g u->v)))
1151                                  (when examine
1152                                        (unless (examine g v) (escape #t)))
1153                                  (case (color g v)
1154                                    ((WHITE)
1155                                     (when tree-edge (tree-edge g u->v))
1156                                     (depth-first-visit v))
1157                                    ((GRAY)
1158                                     (when back-edge (back-edge g u->v)))
1159                                    ((BLACK)
1160                                     (when forward-or-cross-edge
1161                                           (forward-or-cross-edge g u->v)))
1162                                    (else
1163                                     (error "Invalid color" (color g v))))))))
1164                          (,out-edges+ g u))
1165                         (set-color! g u 'BLACK)
1166                         (when finish (finish g u))
1167                         #f)
1168                       (cond ((and (pair? starting-vertex)
1169                                   (eq? 'depth-first-visit
1170                                        (car starting-vertex)))
1171                              (depth-first-visit (cdr starting-vertex)))
1172                             (else
1173                              (,for-each+
1174                               (lambda (u)
1175                                 (set-color! g u 'WHITE)
1176                                 (when init (init g u)))
1177                               (,vertices+ g))
1178                              (when starting-vertex
1179                                    (depth-first-visit starting-vertex))
1180                              (,for-each+
1181                               (lambda (u)
1182                                 (when (eq? (color g u) 'WHITE)
1183                                       (depth-first-visit u)))
1184                               (,vertices+ g))
1185                              #f)))))))
1186            (if streamed? (list #f #t) (list #f)))))
1187(define rgraph-doc-dfv #t)
1188(define-macro
1189  (import-depth-first-visit
1190    GTYPE
1191    streamed?
1192    vertex-set?
1193    edge-set?
1194    directed?
1195    bidirectional?)
1196  `(begin
1197     ,@(map (lambda (streamed?)
1198              (define plus (if streamed? "*" ""))
1199              (define prefix-plus (if streamed? "stream-" ""))
1200              (let ((algorithm+
1201                      (pad GTYPE "-depth-first-visit" plus))
1202                    (depth-first-search+
1203                      (pad GTYPE "-depth-first-search" plus)))
1204                `(define ,algorithm
1205                   (lambda (g dfs-visitor color-map u)
1206                     (,depth-first-search+
1207                      g
1208                      dfs-visitor
1209                      color-map
1210                      (cons 'depth-first-visit u))))))
1211            (if streamed? (list #f #t) (list #f)))))
1212(define rgraph-doc-topsort #t)
1213(define rgraph-doc-topsort #t)
1214(define rgraph-doc-topsort* #t)
1215(define-macro
1216  (import-topological-sort
1217    GTYPE
1218    streamed?
1219    vertex-set?
1220    edge-set?
1221    directed?
1222    bidirectional?)
1223  (define (pad . args)
1224    (string->symbol
1225      (apply string-append
1226             (map (lambda (a)
1227                    (cond ((string? a) a)
1228                          ((symbol? a) (symbol->string a))
1229                          (else "UNKNOWN_PAD_SYMBOL")))
1230                  args))))
1231  `(begin
1232     ,@(map (lambda (streamed?)
1233              (define plus (if streamed? "*" ""))
1234              (define prefix-plus (if streamed? "stream-" ""))
1235              (define (when-s . in-args)
1236                (if streamed? in-args '()))
1237              (define (unless-s . in-args)
1238                (if streamed? '() in-args))
1239              (let ((algorithm+ (pad GTYPE "-topological-sort" plus))
1240                    (depth-first-search+
1241                      (pad GTYPE "-depth-first-search" plus)))
1242                `(define ,algorithm+
1243                   (lambda (g)
1244                     ,@(unless-s
1245                         `(define first #f)
1246                         `(define last #f)
1247                         `(define (add-tail! u)
1248                            (cond (last
1249                                   (set-cdr! last (cons u '()))
1250                                   (set! last (cdr last)))
1251                                  (else
1252                                   (set! first (cons u '()))
1253                                   (set! last first)))))
1254                     (define visitor-LCS #f)
1255                     (define covisitor-LCS
1256                       (lambda (u)
1257                         (let loop ()
1258                           ,@(unless-s `(add-tail! u))
1259                           (set! u (covisitor-resume visitor-LCS #f))
1260                           (loop))))
1261                     (define covisitor-resume
1262                       (lambda (dest val)
1263                         (call/cc
1264                           (lambda (k) (set! covisitor-LCS k) (dest val)))))
1265                     (define (topo-sort-visitor)
1266                       (define visitor (null-dfs-visitor))
1267                       (define visitor-resume
1268                         (lambda (dest val)
1269                           (call/cc
1270                             (lambda (k) (set! visitor-LCS k) (dest val)))))
1271                       (set-dfs-visitor-back-edge!
1272                         visitor
1273                         (lambda (g uv)
1274                           (error "Not a directed, acyclic graph")))
1275                       (set-dfs-visitor-finish!
1276                         visitor
1277                         (lambda (g u) (visitor-resume covisitor-LCS u)))
1278                       visitor)
1279                     ,@(when-s
1280                         `(set! visitor-LCS
1281                            (lambda (val)
1282                              (,depth-first-search+
1283                               g
1284                               (topo-sort-visitor)
1285                               #f
1286                               #f)
1287                              #f))
1288                         `(call/cc
1289                            (lambda (escape)
1290                              (let iterate ((start #t))
1291                                (stream-delay
1292                                  (let ((result
1293                                          (covisitor-resume visitor-LCS #f)))
1294                                    (if result
1295                                      (stream-cons result (iterate #f))
1296                                      (escape stream-null))))))))
1297                     ,@(unless-s
1298                         `(,depth-first-search+
1299                           g
1300                           (topo-sort-visitor)
1301                           #f
1302                           #f)
1303                         `first)))))
1304            (if streamed? (list #f #t) (list #f)))))
1305(define rgraph-doc-part-fidmat #t)
1306(define fidmat-check #t)
1307(define fidmat-debug #t)
1308(define-record partition-fm cost balance vertex)
1309(define-macro
1310  (import-partition-fidmat
1311    GTYPE
1312    streamed?
1313    vertex-set?
1314    edge-set?
1315    directed?
1316    bidirectional?)
1317  (define (pad . args)
1318    (string->symbol
1319      (apply string-append
1320             (map (lambda (a)
1321                    (cond ((string? a) a)
1322                          ((symbol? a) (symbol->string a))
1323                          (else "UNKNOWN_PAD_SYMBOL")))
1324                  args))))
1325  (define (when-bi . in-args)
1326    (if bidirectional? in-args '()))
1327  (define check
1328    (pad GTYPE "-partition-fidmat-check"))
1329  (define debug
1330    (pad GTYPE "-partition-fidmat-debug"))
1331  `(begin
1332     (define ,check #f)
1333     (define ,debug #f)
1334     ,@(map (lambda (streamed?)
1335              (define plus (if streamed? "*" ""))
1336              (define prefix-plus (if streamed? "stream-" ""))
1337              (define for-each+ (pad prefix-plus "for-each"))
1338              (define map+ (pad prefix-plus "map"))
1339              (define null?+ (pad prefix-plus "null?"))
1340              (define car+ (pad prefix-plus "car"))
1341              (define cdr+ (pad prefix-plus "cdr"))
1342              (define algorithm+
1343                (pad GTYPE "-partition-fidmat" plus))
1344              (define vertex-eq? (pad GTYPE "-vertex-eq?"))
1345              (define add-vertex! (pad GTYPE "-add-vertex!"))
1346              (define add-edge! (pad GTYPE "-add-edge!"))
1347              (define remove-edge! (pad GTYPE "-remove-edge!"))
1348              (define clear! (pad GTYPE "-clear!"))
1349              (define vertex (pad GTYPE "-vertex"))
1350              (define source (pad GTYPE "-source"))
1351              (define target (pad GTYPE "-target"))
1352              (define num-vertices (pad GTYPE "-num-vertices"))
1353              (define vertices (pad GTYPE "-vertices"))
1354              (define vertices+ (pad GTYPE "-vertices" plus))
1355              (define out-edges+ (pad GTYPE "-out-edges" plus))
1356              (define neighbours+
1357                (pad GTYPE "-neighbours" plus))
1358              (define out-degree (pad GTYPE "-out-degree"))
1359              `(define ,algorithm+
1360                 (lambda (g
1361                          p-map
1362                          gain
1363                          d-map
1364                          working-g
1365                          working-d-map
1366                          cost
1367                          balance
1368                          weight
1369                          criterion
1370                          split-level)
1371                   (let* ((L (,num-vertices g))
1372                          (L1 (quotient
1373                                (* (car weight) L)
1374                                (+ (car weight) (cdr weight))))
1375                          (DEGREE 0)
1376                          (p (car p-map))
1377                          (set-p! (cdr p-map))
1378                          (d (car d-map))
1379                          (set-d! (cdr d-map))
1380                          (working-d (car working-d-map))
1381                          (set-working-d! (cdr working-d-map)))
1382                     (define (vertex-at gain)
1383                       (if ,vertex-set?
1384                         gain
1385                         (,vertex working-g (+ gain DEGREE))))
1386                     (,for-each+
1387                      (lambda (u)
1388                        (set-p! g u #t)
1389                        (let ((d (,out-degree g u)))
1390                          (when (> d DEGREE) (set! DEGREE d))))
1391                      (,vertices+ g))
1392                     (set! DEGREE (* 2 DEGREE))
1393                     (let loop1 ((n#t L) (n#f 0))
1394                       (when (call/cc
1395                               (lambda (escape)
1396                                 (,for-each+
1397                                  (lambda (u)
1398                                    (let ((part (p g u)))
1399                                      (when (and part
1400                                                 (< (random n#t) (- n#t L1)))
1401                                            (set! n#f (add1 n#f))
1402                                            (if (> n#f L1) (escape #f))
1403                                            (set-p! g u #f))))
1404                                  (,vertices+ g))
1405                                 #t))
1406                             (loop1 (- L n#f) n#f)))
1407                     (let loop1 ((initial-cost (cost)))
1408                       (let ((initial-p
1409                               (map (lambda (x) (p g x)) (,vertices g)))
1410                             (current-cost #f)
1411                             (n#f #f)
1412                             (n#t #f)
1413                             (costs #f)
1414                             (lop #f))
1415                         (set! n#f (rgraph-count not initial-p))
1416                         (set! n#t (- L n#f))
1417                         (set! current-cost initial-cost)
1418                         (when ,debug
1419                               (print "Start with all cells free")
1420                               (print " initial-cost: " initial-cost))
1421                         (,clear! working-g)
1422                         (do ((i (- DEGREE) (add1 i)))
1423                             ((> i DEGREE))
1424                           (,add-vertex! working-g i))
1425                         (when ,debug
1426                               (print "Add all cells to gain bucket"))
1427                         (,for-each+
1428                          (lambda (u)
1429                            (let ((w-v (,add-vertex! working-g u))
1430                                  (gain (gain g u)))
1431                              (when ,check
1432                                    (when (> (abs gain) DEGREE)
1433                                          (error "Gain is outside of [-DEGREE,+DEGREE]"
1434                                                 DEGREE
1435                                                 gain)))
1436                              (set-working-d! g w-v u)
1437                              (set-d!
1438                                g
1439                                u
1440                                (,add-edge! working-g (vertex-at gain) w-v))))
1441                          (,vertices+ g))
1442                         (when ,debug
1443                               (print "Repeat until no cells free"))
1444                         (set! costs
1445                           (let loop2 ((cells-free L))
1446                             (cond ((= cells-free 0) '())
1447                                   (else
1448                                    (let ((largest #f) (largest-gain 0))
1449                                      (when ,debug
1450                                            (print "Move cell with largest gain"))
1451                                      (set! largest-gain
1452                                        (call/cc
1453                                          (lambda (escape)
1454                                            (do ((i DEGREE (sub1 i)))
1455                                                ((< i (- DEGREE)))
1456                                              (let* ((w-gv (vertex-at i))
1457                                                     (w-out (,out-edges+
1458                                                             working-g
1459                                                             w-gv)))
1460                                                (unless
1461                                                  (,null?+ w-out)
1462                                                  (let ((w-first
1463                                                          (,car+ w-out)))
1464                                                    (set! largest
1465                                                      (working-d
1466                                                        g
1467                                                        (,target g w-first)))
1468                                                    (,remove-edge!
1469                                                     working-g
1470                                                     w-first)
1471                                                    (escape i)))))
1472                                            (error "No cells to move, yet FM algorithm running")
1473                                            0)))
1474                                      (set! current-cost
1475                                        (- current-cost largest-gain))
1476                                      (cond ((p g largest)
1477                                             (set! n#f (add1 n#f))
1478                                             (set! n#t (sub1 n#t)))
1479                                            (else
1480                                             (set! n#t (add1 n#t))
1481                                             (set! n#f (sub1 n#f))))
1482                                      (set-p! g largest (not (p g largest)))
1483                                      (when ,debug
1484                                            (print "Update cost of neighbours"))
1485                                      (,for-each+
1486                                       (lambda (nb)
1487                                         (when ,debug
1488                                               (print " neighbour: " (car nb)))
1489                                         (let* ((u (car nb)) (w-gvu (d g u)))
1490                                           (when w-gvu
1491                                                 (,remove-edge!
1492                                                  working-g
1493                                                  w-gvu)
1494                                                 (set-d!
1495                                                   g
1496                                                   u
1497                                                   (,add-edge!
1498                                                    working-g
1499                                                    (vertex-at (gain g u))
1500                                                    (,target
1501                                                     working-g
1502                                                     w-gvu))))))
1503                                       (,neighbours+ g largest))
1504                                      (set-d! g largest #f)
1505                                      (when ,debug (print "Note current cost"))
1506                                      (and ,check
1507                                           (not (= (cost) current-cost))
1508                                           (error "Bug found where (cost) does not equal current-cost"
1509                                                  (cost)
1510                                                  current-cost))
1511                                      (cons (make-partition-fm
1512                                              current-cost
1513                                              (balance weight n#f n#t)
1514                                              largest)
1515                                            (loop2 (- cells-free 1))))))))
1516                         (when ,debug (print "Pick least cost point"))
1517                         (for-each
1518                           (lambda (fmv)
1519                             (and (< (partition-fm-cost fmv) initial-cost)
1520                                  (or (not lop)
1521                                      (< (partition-fm-cost fmv)
1522                                         (partition-fm-cost lop)))
1523                                  (<= (partition-fm-balance fmv) criterion)
1524                                  (set! lop fmv)))
1525                           costs)
1526                         (when ,debug
1527                               (print "  local optimal point cost: "
1528                                      (if lop (partition-fm-cost lop) "none")))
1529                         (let reset ((vertices (,vertices+ g))
1530                                     (initial initial-p))
1531                           (cond ((not (,null?+ vertices))
1532                                  (set-p! g (,car+ vertices) (car initial))
1533                                  (reset (,cdr+ vertices) (cdr initial)))))
1534                         (and lop
1535                              (let apply-moves ((costs costs))
1536                                (let ((u (partition-fm-vertex (car costs)))
1537                                      (cost (partition-fm-cost (car costs))))
1538                                  (cond ((null? costs))
1539                                        (else
1540                                         (set-p! g u (not (p g u)))
1541                                         (or (eq? lop (car costs))
1542                                             (apply-moves (cdr costs))))))))
1543                         (unless
1544                           (zero? initial-cost)
1545                           (let ((c (cost)) (l split-level))
1546                             (cond ((zero? l))
1547                                   ((= l 1)
1548                                    (when (>= (quotient initial-cost c) 2)
1549                                          (loop1 c)))
1550                                   (else
1551                                    (unless
1552                                      (= initial-cost c)
1553                                      (loop1 c))))))))))))
1554            (if streamed? (list #f #t) (list #f)))))
1555(define rgraph-doc-partition-fidmat-check #t)
1556(define rgraph-doc-partition-fidmat-debug #t)
Note: See TracBrowser for help on using the repository browser.