source: project/release/3/rgraph/trunk/rgraph.scm @ 33923

Last change on this file since 33923 was 10005, checked in by Kon Lovett, 13 years ago

Fixes for wrong param order w/ srfi-69 procs, misspelled varaiables, no feature for srfi-40, missing param. (Did this ever work?).

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