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

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

Using canonical directory structure.

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