source: project/rgraph/rgraph-test1.scm @ 1

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

Import everything.

File size: 54.5 KB
Line 
1(when #t
2      (let ((args '(myg (fill-graph!)
3                        (vl-vector)
4                        (vertex-name vertex-color)
5                        (el-slist)
6                        (edge-weight edge-color)
7                        #f
8                        #t)))
9        (printf
10          "~%~a~%"
11          (cons "DEFINE-ADJACENCY-LIST" args))
12        (pretty-print
13          (apply (lambda (GTYPE
14                          algorithms
15                          VTYPE
16                          vertex-properties
17                          ETYPE
18                          edge-properties
19                          directed?
20                          bidirectional?)
21                   (define (pad . args)
22                     (string->symbol
23                       (apply string-append
24                              (map (lambda (a)
25                                     (cond ((string? a) a)
26                                           ((symbol? a) (symbol->string a))
27                                           (else "UNKNOWN_PAD_SYMBOL")))
28                                   args))))
29                   (define (when-bi . in-args)
30                     (if bidirectional? in-args '()))
31                   (define (when-bi-or-dir . in-args)
32                     (if (or bidirectional? directed?) in-args '()))
33                   (let* ((NVP (length vertex-properties))
34                          (NEP (length edge-properties))
35                          (rec GTYPE)
36                          (rec? (gensym))
37                          (make-rec (gensym))
38                          (rec-vl (gensym))
39                          (set-rec-vl! (gensym))
40                          (rec-pgetters (gensym))
41                          (rec-psetters (gensym))
42                          (streamed? (cond-expand (srfi-40 #t) (else #f)))
43                          (vertex-set? (pad GTYPE "-vertex-set?"))
44                          (edge-set? (pad GTYPE "-edge-set?"))
45                          (constructor (pad "make-" GTYPE))
46                          (add-edge! (pad GTYPE "-add-edge!"))
47                          (remove-edge! (pad GTYPE "-remove-edge!"))
48                          (remove-edge2! (pad GTYPE "-remove-edge2!"))
49                          (add-directed-edge!
50                            (pad "##carp#" GTYPE "-add-directed-edge!"))
51                          (remove-directed-edge!
52                            (pad "##carp#" GTYPE "-remove-directed-edge!"))
53                          (out-edges (pad GTYPE "-out-edges"))
54                          (out-edges* (pad GTYPE "-out-edges*"))
55                          (out-degree (pad GTYPE "-out-degree"))
56                          (in-edges (pad GTYPE "-in-edges"))
57                          (in-edges* (pad GTYPE "-in-edges*"))
58                          (in-degree (pad GTYPE "-in-degree"))
59                          (neighbours (pad GTYPE "-neighbours"))
60                          (neighbours* (pad GTYPE "-neighbours*"))
61                          (import-vertex-list (pad "define-" (car VTYPE)))
62                          (import-edge-list (pad "define-" (car ETYPE)))
63                          (vl-constructor (pad "##carp#make-" GTYPE "-vl"))
64                          (source (pad GTYPE "-source"))
65                          (target (pad GTYPE "-target"))
66                          (out-edge-list
67                            (pad "##carp#" GTYPE "-out-edge-list"))
68                          (in-edge-list
69                            (pad "##carp#" GTYPE "-in-edge-list"))
70                          (edges (pad "##carp#" GTYPE "-edges"))
71                          (edges* (pad "##carp#" GTYPE "-edges*"))
72                          (degree (pad "##carp#" GTYPE "-degree")))
73                     `(begin
74                        (define-record-type
75                          ,rec
76                          (,make-rec vl pgetters psetters)
77                          ,rec?
78                          (vl ,rec-vl ,set-rec-vl!)
79                          (pgetters ,rec-pgetters)
80                          (psetters ,rec-psetters))
81                        (,import-edge-list
82                         ,GTYPE
83                         ,(cdr ETYPE)
84                         ,streamed?
85                         ,bidirectional?
86                         ,edge-properties)
87                        (,import-vertex-list
88                         ,GTYPE
89                         ,(cdr VTYPE)
90                         ,streamed?
91                         ,bidirectional?
92                         ,vertex-properties
93                         ,rec-vl)
94                        (define-record-printer
95                          ,rec
96                          (lambda (x p)
97                            (fprintf p "Adjacency List~%")
98                            (fprintf p "num-vertex-props        ~S~%" ,NVP)
99                            (fprintf p "num-edge-props  ~S" ,NEP)))
100                        (define ,constructor
101                          (lambda ()
102                            (let* ((pgetters
103                                     (make-hash-table eq? ,(+ NVP NEP)))
104                                   (psetters
105                                     (make-hash-table eq? ,(+ NVP NEP)))
106                                   (rec (,make-rec #f pgetters psetters)))
107                              (,set-rec-vl! rec (,vl-constructor rec))
108                              ,@(map (lambda (prop)
109                                       (define getter (pad GTYPE "-" prop))
110                                       (define setter
111                                         (pad "set-" GTYPE "-" prop "!"))
112                                       `(begin
113                                          (hash-table-set!
114                                            pgetters
115                                            ',prop
116                                            ,getter)
117                                          (hash-table-set!
118                                            psetters
119                                            ',prop
120                                            ,setter)))
121                                     (append
122                                       vertex-properties
123                                       edge-properties))
124                              rec)))
125                        (define ,add-edge!
126                          (lambda (g u v)
127                            (let ((ret (,add-directed-edge!
128                                        g
129                                        u
130                                        (,out-edge-list g u)
131                                        v)))
132                              ,@(when-bi
133                                  `(,add-directed-edge!
134                                    g
135                                    v
136                                    (,in-edge-list g v)
137                                    u))
138                              (unless
139                                ,directed?
140                                (,add-directed-edge!
141                                 g
142                                 v
143                                 (,out-edge-list g v)
144                                 u)
145                                ,@(when-bi
146                                    `(,add-directed-edge!
147                                      g
148                                      u
149                                      (,in-edge-list g u)
150                                      v)))
151                              ret)))
152                        (define ,remove-edge!
153                          (lambda (g e)
154                            (,remove-edge2! g (,source g e) (,target g e))))
155                        (define ,remove-edge2!
156                          (lambda (g u v)
157                            (let ((ret (,remove-directed-edge!
158                                        g
159                                        u
160                                        (,out-edge-list g u)
161                                        v)))
162                              ,@(when-bi
163                                  `(,remove-directed-edge!
164                                    g
165                                    v
166                                    (,in-edge-list g v)
167                                    u))
168                              (unless
169                                ,directed?
170                                (,remove-directed-edge!
171                                 g
172                                 v
173                                 (,out-edge-list g v)
174                                 u)
175                                ,@(when-bi
176                                    `(,remove-directed-edge!
177                                      g
178                                      u
179                                      (,in-edge-list g u)
180                                      v)))
181                              ret)))
182                        (define ,out-edges
183                          (lambda (g u)
184                            (,edges g u (,out-edge-list g u) #t)))
185                        (define ,out-edges*
186                          (lambda (g u)
187                            (,edges* g u (,out-edge-list g u) #t)))
188                        (define ,out-degree
189                          (lambda (g u) (,degree g u (,out-edge-list g u))))
190                        ,@(when-bi
191                            `(define ,in-edges
192                               (lambda (g u)
193                                 (,edges g u (,in-edge-list g u) #f)))
194                            `(define ,in-edges*
195                               (lambda (g u)
196                                 (,edges* g u (,in-edge-list g u) #f)))
197                            `(define ,in-degree
198                               (lambda (g u)
199                                 (,degree g u (,in-edge-list g u)))))
200                        ,@(when-bi-or-dir
201                            `(define ,neighbours
202                               (lambda (g u)
203                                 (append
204                                   (map (lambda (e) (cons (,target g e) e))
205                                        (,out-edges g u))
206                                   (map (lambda (e) (cons (,source g e) e))
207                                        (,in-edges g u)))))
208                            `(define ,neighbours*
209                               (lambda (g u)
210                                 (stream-append
211                                   (stream-map
212                                     (lambda (e) (cons (,target g e) e))
213                                     (,out-edges* g u))
214                                   (stream-map
215                                     (lambda (e) (cons (,source g e) e))
216                                     (,in-edges* g u))))))
217                        ,@(map (lambda (algorithm)
218                                 `(,(pad "import-" algorithm)
219                                   ,GTYPE
220                                   ,streamed?
221                                   (,vertex-set?)
222                                   (,edge-set?)
223                                   ,directed?
224                                   ,bidirectional?))
225                               algorithms))))
226                 args))))
227(when #t
228      (let ((args '(myg ()
229                        #t
230                        #t
231                        (vertex-name vertex-color)
232                        Imported-Vertex-List-Record)))
233        (printf "~%~a~%" (cons "DEFINE-VL-VECTOR" args))
234        (pretty-print
235          (apply (lambda (GTYPE
236                          VARGS
237                          streamed?
238                          bidirectional?
239                          vertex-properties
240                          get-vl)
241                   (define (pad . args)
242                     (string->symbol
243                       (apply string-append
244                              (map (lambda (a)
245                                     (cond ((string? a) a)
246                                           ((symbol? a) (symbol->string a))
247                                           (else "UNKNOWN_PAD_SYMBOL")))
248                                   args))))
249                   (define plus (if streamed? "*" ""))
250                   (define prefix-plus (if streamed? "stream-" ""))
251                   (define (when-bi . in-args)
252                     (if bidirectional? in-args '()))
253                   (define (unless-bi . in-args)
254                     (if bidirectional? '() in-args))
255                   (let* ((for-each+ (pad prefix-plus "for-each"))
256                          (map+ (pad prefix-plus "map"))
257                          (NP (length vertex-properties))
258                          (vl (pad GTYPE "-vertex-list"))
259                          (vl? (gensym))
260                          (make-vl (gensym))
261                          (vl-num (gensym))
262                          (set-vl-num! (gensym))
263                          (vl-vec (gensym))
264                          (set-vl-vec! (gensym))
265                          (rec (pad GTYPE "-vertex"))
266                          (rec? (gensym))
267                          (make-rec (gensym))
268                          (rec-out-edge-l (gensym))
269                          (set-rec-out-edge-l! (gensym))
270                          (rec-in-edge-l (gensym))
271                          (set-rec-in-edge-l! (gensym))
272                          (rec-props (gensym))
273                          (set-rec-props! (gensym))
274                          (vertex-set? (pad GTYPE "-vertex-set?"))
275                          (constructor (pad "##carp#make-" GTYPE "-vl"))
276                          (check-valid (gensym))
277                          (vertex-index (pad GTYPE "-vertex-index"))
278                          (add-vertex! (pad GTYPE "-add-vertex!"))
279                          (remove-vertex! (pad GTYPE "-remove-vertex!"))
280                          (vertex (pad GTYPE "-vertex"))
281                          (vertex-eq? (pad GTYPE "-vertex-eq?"))
282                          (out-edge-list
283                            (pad "##carp#" GTYPE "-out-edge-list"))
284                          (in-edge-list
285                            (pad "##carp#" GTYPE "-in-edge-list"))
286                          (num-vertices (pad GTYPE "-num-vertices"))
287                          (vertices (pad GTYPE "-vertices"))
288                          (vertices* (pad GTYPE "-vertices*"))
289                          (clear! (pad GTYPE "-clear!"))
290                          (el-constructor (pad "##carp#make-" GTYPE "-el"))
291                          (edge (pad GTYPE "-edge"))
292                          (in-edges+ (pad GTYPE "-in-edges" plus))
293                          (out-edges+ (pad GTYPE "-out-edges" plus))
294                          (remove-edge! (pad GTYPE "-remove-edge!"))
295                          (transform-vertices!
296                            (pad "##carp#" GTYPE "-transform-vertices!")))
297                     `(begin
298                        (define-macro ,vertex-set? (lambda () `#f))
299                        (define-record-type
300                          ,vl
301                          (,make-vl num vec)
302                          ,vl?
303                          (num ,vl-num ,set-vl-num!)
304                          (vec ,vl-vec ,set-vl-vec!))
305                        (define-record-printer
306                          ,vl
307                          (lambda (x p)
308                            (fprintf p "Vertex List vl-vector~%")
309                            (fprintf p "size    ~S" (,vl-num x))))
310                        (define-record-type
311                          ,rec
312                          (,make-rec
313                           out-edge-l
314                           ,@(when-bi 'in-edge-l)
315                           props)
316                          ,rec?
317                          (out-edge-l ,rec-out-edge-l ,set-rec-out-edge-l!)
318                          ,@(when-bi
319                              `(in-edge-l ,rec-in-edge-l ,set-rec-in-edge-l!))
320                          (props ,rec-props ,set-rec-props!))
321                        (define-record-printer
322                          ,rec
323                          (lambda (x p) (fprintf p "Vertex ~S" x)))
324                        (define ,constructor
325                          (lambda (g) (,make-vl 0 (make-vector 0))))
326                        (define-macro
327                          ,check-valid
328                          (lambda (u num)
329                            `(rgraph-debug
330                               (when (or (not (integer? ,u))
331                                         (< ,u 0)
332                                         (>= ,u ,num))
333                                     (error "Invalid vl-vector vertex descriptor")))))
334                        (define ,vertex-index
335                          (lambda (g v)
336                            (,check-valid v (,vl-num (,get-vl g)))
337                            v))
338                        ,@(let ((index -1))
339                            (map (lambda (prop)
340                                   (let ((getter (pad GTYPE "-" prop))
341                                         (setter!
342                                           (pad "set-" GTYPE "-" prop "!"))
343                                         (pmap (pad GTYPE "-" prop "-map")))
344                                     (set! index (add1 index))
345                                     `(begin
346                                        (define ,getter
347                                          (lambda (g v)
348                                            (,check-valid
349                                             v
350                                             (,vl-num (,get-vl g)))
351                                            (vector-ref
352                                              (,rec-props
353                                               (vector-ref
354                                                 (,vl-vec (,get-vl g))
355                                                 v))
356                                              ,index)))
357                                        (define ,setter!
358                                          (lambda (g v p)
359                                            (,check-valid
360                                             v
361                                             (,vl-num (,get-vl g)))
362                                            (vector-set!
363                                              (,rec-props
364                                               (vector-ref
365                                                 (,vl-vec (,get-vl g))
366                                                 v))
367                                              ,index
368                                              p)))
369                                        (define ,pmap
370                                          (cons ,getter ,setter!)))))
371                                 vertex-properties))
372                        (define ,add-vertex!
373                          (lambda (g . ignored)
374                            (let* ((vl (,get-vl g))
375                                   (num (,vl-num vl))
376                                   (vec (,vl-vec vl))
377                                   (length (vector-length vec))
378                                   (rec (,make-rec
379                                         (,el-constructor g)
380                                         ,@(when-bi `(,el-constructor g))
381                                         (make-vector ,NP #f))))
382                              (cond ((< num length))
383                                    ((zero? length)
384                                     (set! vec (make-vector 1 #f)))
385                                    (else
386                                     (set! vec
387                                       (vector-resize
388                                         vec
389                                         (max 2 (quotient (* 17 length) 10))
390                                         #f))))
391                              (vector-set! vec num rec)
392                              (,set-vl-vec! vl vec)
393                              (,set-vl-num! vl (add1 num))
394                              num)))
395                        (define ,remove-vertex!
396                          (lambda (g u)
397                            (let* ((vl (,get-vl g))
398                                   (num (,vl-num vl))
399                                   (num-- (sub1 num))
400                                   (vec (,vl-vec vl))
401                                   (length (vector-length vec))
402                                   (down (quotient (* 10 length) 17)))
403                              (,check-valid u num)
404                              (,for-each+
405                               (lambda (u^v) (,remove-edge! g u^v))
406                               (,out-edges+ g u))
407                              ,@(when-bi
408                                  `(,for-each+
409                                    (lambda (v^u) (,remove-edge! g v^u))
410                                    (,in-edges+ g u)))
411                              ,@(unless-bi
412                                  `(do ((v 0 (add1 v)))
413                                       ((>= v num))
414                                     (let ((v^u (,edge g v u)))
415                                       (when v^u (,remove-edge! g v^u)))))
416                              (cond ((< num down)
417                                     (set! vec (vector-resize vec down))
418                                     (,set-vl-vec! vl vec)))
419                              (let loop ((n u))
420                                (cond ((> n num--))
421                                      ((= n num--) (vector-set! vec n #f))
422                                      (else
423                                       (vector-set!
424                                         vec
425                                         n
426                                         (vector-ref vec (add1 n)))
427                                       (loop (add1 n)))))
428                              (,set-vl-num! vl (sub1 num))
429                              (do ((i 0 (add1 i)))
430                                  ((>= i num--))
431                                (,transform-vertices!
432                                 (lambda (v) (if (> v u) (sub1 v) v))
433                                 g
434                                 i)))))
435                        (define ,vertex
436                          (lambda (g n)
437                            (let* ((vl (,get-vl g)) (num (,vl-num vl)))
438                              (,check-valid n num)
439                              n)))
440                        (define ,vertex-eq?
441                          (lambda (g u v)
442                            (,check-valid u (,vl-num (,get-vl g)))
443                            (,check-valid v (,vl-num (,get-vl g)))
444                            (= u v)))
445                        (define ,out-edge-list
446                          (lambda (g u)
447                            (let* ((vl (,get-vl g))
448                                   (num (,vl-num vl))
449                                   (vec (,vl-vec vl)))
450                              (,check-valid u num)
451                              (,rec-out-edge-l (vector-ref vec u)))))
452                        ,@(when-bi
453                            `(define ,in-edge-list
454                               (lambda (g u)
455                                 (let* ((vl (,get-vl g))
456                                        (num (,vl-num vl))
457                                        (vec (,vl-vec vl)))
458                                   (,check-valid u num)
459                                   (,rec-in-edge-l (vector-ref vec u))))))
460                        (define ,vertices
461                          (lambda (g)
462                            (let* ((vl (,get-vl g)) (num (,vl-num vl)))
463                              (let iter ((i 0))
464                                (cond ((= i num) '())
465                                      (else (cons i (iter (add1 i)))))))))
466                        (define ,vertices*
467                          (lambda (g)
468                            (let* ((vl (,get-vl g)) (num (,vl-num vl)))
469                              (let iter ((i 0))
470                                (stream-delay
471                                  (cond ((= i num) stream-null)
472                                        (else
473                                         (stream-cons i (iter (add1 i))))))))))
474                        (define ,num-vertices
475                          (lambda (g)
476                            (let* ((vl (,get-vl g)) (num (,vl-num vl))) num)))
477                        (define ,clear!
478                          (lambda (g)
479                            (let ((vl (,get-vl g)))
480                              (,set-vl-num! vl 0)
481                              (,set-vl-vec! vl (make-vector 0))))))))
482                 args))))
483(when #t
484      (let ((args '(myg (Some-Hashtable-Eq? 2499)
485                        #t
486                        #t
487                        (vertex-name vertex-color)
488                        Imported-Vertex-List-Record)))
489        (printf "~%~a~%" (cons "DEFINE-VL-HASH" args))
490        (pretty-print
491          (apply (lambda (GTYPE
492                          VARGS
493                          streamed?
494                          bidirectional?
495                          vertex-properties
496                          get-vl)
497                   (define (pad . args)
498                     (string->symbol
499                       (apply string-append
500                              (map (lambda (a)
501                                     (cond ((string? a) a)
502                                           ((symbol? a) (symbol->string a))
503                                           (else "UNKNOWN_PAD_SYMBOL")))
504                                   args))))
505                   (define plus (if streamed? "*" ""))
506                   (define prefix-plus (if streamed? "stream-" ""))
507                   (define (when-bi . in-args)
508                     (if bidirectional? in-args '()))
509                   (define (unless-bi . in-args)
510                     (if bidirectional? '() in-args))
511                   (let* ((for-each+ (pad prefix-plus "for-each"))
512                          (map+ (pad prefix-plus "map"))
513                          (NP (length vertex-properties))
514                          (vl (pad GTYPE "-vertex-list"))
515                          (vl? (gensym))
516                          (make-vl (gensym))
517                          (vl-table (gensym))
518                          (set-vl-table! (gensym))
519                          (vl-max-index (gensym))
520                          (set-vl-max-index! (gensym))
521                          (rec (pad GTYPE "-vertex"))
522                          (rec? (gensym))
523                          (make-rec (gensym))
524                          (rec-index (gensym))
525                          (set-rec-index! (gensym))
526                          (rec-out-edge-l (gensym))
527                          (set-rec-out-edge-l! (gensym))
528                          (rec-in-edge-l (gensym))
529                          (set-rec-in-edge-l! (gensym))
530                          (rec-props (gensym))
531                          (set-rec-props! (gensym))
532                          (vertex-set? (pad GTYPE "-vertex-set?"))
533                          (constructor (pad "##carp#make-" GTYPE "-vl"))
534                          (check-valid (gensym))
535                          (vertex-index (pad GTYPE "-vertex-index"))
536                          (add-vertex! (pad GTYPE "-add-vertex!"))
537                          (remove-vertex! (pad GTYPE "-remove-vertex!"))
538                          (vertex (pad GTYPE "-vertex"))
539                          (vertex-eq? (pad GTYPE "-vertex-eq?"))
540                          (out-edge-list
541                            (pad "##carp#" GTYPE "-out-edge-list"))
542                          (in-edge-list
543                            (pad "##carp#" GTYPE "-in-edge-list"))
544                          (num-vertices (pad GTYPE "-num-vertices"))
545                          (vertices (pad GTYPE "-vertices"))
546                          (vertices* (pad GTYPE "-vertices*"))
547                          (clear! (pad GTYPE "-clear!"))
548                          (el-constructor (pad "##carp#make-" GTYPE "-el"))
549                          (edge (pad GTYPE "-edge"))
550                          (in-edges+ (pad GTYPE "-in-edges" plus))
551                          (out-edges+ (pad GTYPE "-out-edges" plus))
552                          (remove-edge! (pad GTYPE "-remove-edge!"))
553                          (transform-vertices!
554                            (pad "##carp#" GTYPE "-transform-vertices!")))
555                     `(begin
556                        (define-macro ,vertex-set? (lambda () `#t))
557                        (define-record-type
558                          ,vl
559                          (,make-vl table max-index)
560                          ,vl?
561                          (table ,vl-table ,set-vl-table!)
562                          (max-index ,vl-max-index ,set-vl-max-index!))
563                        (define-record-printer
564                          ,vl
565                          (lambda (x p)
566                            (fprintf p "Vertex List vl-hash~%")
567                            (fprintf
568                              p
569                              "size     ~S"
570                              (hash-table-size (,vl-table x)))))
571                        (define-record-type
572                          ,rec
573                          (,make-rec
574                           index
575                           out-edge-l
576                           ,@(when-bi 'in-edge-l)
577                           props)
578                          ,rec?
579                          (index ,rec-index ,set-rec-index!)
580                          (out-edge-l ,rec-out-edge-l ,set-rec-out-edge-l!)
581                          ,@(when-bi
582                              `(in-edge-l ,rec-in-edge-l ,set-rec-in-edge-l!))
583                          (props ,rec-props ,set-rec-props!))
584                        (define-record-printer
585                          ,rec
586                          (lambda (x p) (fprintf p "Vertex ~S" x)))
587                        (define ,constructor
588                          (lambda (g)
589                            (,make-vl (make-hash-table ,@VARGS) 0)))
590                        (define-macro ,check-valid (lambda (u) #t))
591                        (define ,vertex-index
592                          (lambda (g v)
593                            (let* ((vl (,get-vl g))
594                                   (table (,vl-table vl))
595                                   (rec (hash-table-ref table v)))
596                              (,rec-index rec))
597                            v))
598                        ,@(let ((index -1))
599                            (map (lambda (prop)
600                                   (let ((getter (pad GTYPE "-" prop))
601                                         (setter!
602                                           (pad "set-" GTYPE "-" prop "!"))
603                                         (pmap (pad GTYPE "-" prop "-map")))
604                                     (set! index (add1 index))
605                                     `(begin
606                                        (define ,getter
607                                          (lambda (g v)
608                                            (,check-valid v)
609                                            (vector-ref
610                                              (,rec-props
611                                               (hash-table-ref
612                                                 (,vl-table (,get-vl g))
613                                                 v))
614                                              ,index)))
615                                        (define ,setter!
616                                          (lambda (g v p)
617                                            (,check-valid v)
618                                            (vector-set!
619                                              (,rec-props
620                                               (hash-table-ref
621                                                 (,vl-table (,get-vl g))
622                                                 v))
623                                              ,index
624                                              p)))
625                                        (define ,pmap
626                                          (cons ,getter ,setter!)))))
627                                 vertex-properties))
628                        (define ,add-vertex!
629                          (lambda (g key . ignored)
630                            (let* ((vl (,get-vl g))
631                                   (table (,vl-table vl))
632                                   (rec (hash-table-ref table key)))
633                              (unless
634                                rec
635                                (let ((index (,vl-max-index vl)))
636                                  (hash-table-set!
637                                    table
638                                    key
639                                    (,make-rec
640                                     index
641                                     (,el-constructor g)
642                                     ,@(when-bi `(,el-constructor g))
643                                     (make-vector ,NP #f)))
644                                  (,set-vl-max-index! vl (add1 index))))
645                              key)))
646                        (define ,remove-vertex!
647                          (lambda (g u)
648                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
649                              (,check-valid u)
650                              (,for-each+
651                               (lambda (u^v) (,remove-edge! g u^v))
652                               (,out-edges+ g u))
653                              ,@(when-bi
654                                  `(,for-each+
655                                    (lambda (v^u) (,remove-edge! g v^u))
656                                    (,in-edges+ g u)))
657                              ,@(unless-bi
658                                  `(do ((v 0 (add1 v)))
659                                       ((>= v num))
660                                     (let ((v^u (,edge g v u)))
661                                       (when v^u (,remove-edge! g v^u)))))
662                              (hash-table-delete! table u))))
663                        (define ,vertex-eq?
664                          (lambda (g u v)
665                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
666                              (,check-valid u)
667                              (,check-valid v)
668                              (,(if (pair? VARGS) (car VARGS) 'eq?) u v))))
669                        (define ,out-edge-list
670                          (lambda (g u)
671                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
672                              (,check-valid u)
673                              (,rec-out-edge-l (hash-table-ref table u)))))
674                        ,@(when-bi
675                            `(define ,in-edge-list
676                               (lambda (g u)
677                                 (let* ((vl (,get-vl g))
678                                        (table (,vl-table vl)))
679                                   (,check-valid u)
680                                   (,rec-in-edge-l
681                                    (hash-table-ref table u))))))
682                        (define ,vertices
683                          (lambda (g)
684                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
685                              (hash-table-map (lambda (k v) k) table))))
686                        (define ,vertices*
687                          (lambda (g)
688                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
689                              (stream-map
690                                (lambda (kv) (car kv))
691                                (hash-table->stream table)))))
692                        (define ,num-vertices
693                          (lambda (g)
694                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
695                              (hash-table-size table))))
696                        (define ,clear!
697                          (lambda (g)
698                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
699                              (clear-hash-table! table)))))))
700                 args))))
701(when #t
702      (let ((args '(myg () #t #t (edge-weight edge-color))))
703        (printf "~%~a~%" (cons "DEFINE-EL-SLIST" args))
704        (pretty-print
705          (apply (lambda (GTYPE
706                          VARGS
707                          streamed?
708                          bidirectional?
709                          edge-properties)
710                   (define (pad . args)
711                     (string->symbol
712                       (apply string-append
713                              (map (lambda (a)
714                                     (cond ((string? a) a)
715                                           ((symbol? a) (symbol->string a))
716                                           (else "UNKNOWN_PAD_SYMBOL")))
717                                   args))))
718                   (define (when-bi . in-args)
719                     (if bidirectional? in-args '()))
720                   (let* ((NP (length edge-properties))
721                          (el (pad GTYPE "-edge-list"))
722                          (el? (gensym))
723                          (make-el (gensym))
724                          (el-tlist (gensym))
725                          (set-el-tlist! (gensym))
726                          (el-tnum (gensym))
727                          (set-el-tnum! (gensym))
728                          (rec (pad GTYPE "-edge"))
729                          (rec? (gensym))
730                          (make-rec (gensym))
731                          (rec-target (gensym))
732                          (set-rec-target! (gensym))
733                          (rec-props (gensym))
734                          (set-rec-props! (gensym))
735                          (edge-set? (pad GTYPE "-edge-set?"))
736                          (constructor (pad "##carp#make-" GTYPE "-el"))
737                          (add-directed-edge!
738                            (pad "##carp#" GTYPE "-add-directed-edge!"))
739                          (remove-directed-edge!
740                            (pad "##carp#" GTYPE "-remove-directed-edge!"))
741                          (edge (pad GTYPE "-edge"))
742                          (source (pad GTYPE "-source"))
743                          (target (pad GTYPE "-target"))
744                          (edges (pad "##carp#" GTYPE "-edges"))
745                          (edges* (pad "##carp#" GTYPE "-edges*"))
746                          (edge-at (pad GTYPE "-edge-at"))
747                          (degree (pad "##carp#" GTYPE "-degree"))
748                          (transform-vertices!
749                            (pad "##carp#" GTYPE "-transform-vertices!"))
750                          (out-edge-list
751                            (pad "##carp#" GTYPE "-out-edge-list"))
752                          (in-edge-list
753                            (pad "##carp#" GTYPE "-in-edge-list"))
754                          (vertex-eq? (pad GTYPE "-vertex-eq?")))
755                     `(begin
756                        (define-macro ,edge-set? (lambda () `#f))
757                        (define-record-type
758                          ,el
759                          (,make-el tlist tnum)
760                          ,el?
761                          (tlist ,el-tlist ,set-el-tlist!)
762                          (tnum ,el-tnum ,set-el-tnum!))
763                        (define-record-printer
764                          ,el
765                          (lambda (x p)
766                            (fprintf p "Edge List el-slist~%")
767                            (fprintf p "degree  ~S" (,el-tnum x))))
768                        (define-record-type
769                          ,rec
770                          (,make-rec target props)
771                          ,rec?
772                          (target ,rec-target ,set-rec-target!)
773                          (props ,rec-props ,set-rec-props!))
774                        (define-record-printer
775                          ,rec
776                          (lambda (x p)
777                            (fprintf
778                              p
779                              "Edge | target vertex     ~S"
780                              (,rec-target x))))
781                        (define ,constructor
782                          (lambda (g) (,make-el '() 0)))
783                        ,@(let ((index -1))
784                            (map (lambda (prop)
785                                   (let ((getter (pad GTYPE "-" prop))
786                                         (setter!
787                                           (pad "set-" GTYPE "-" prop "!"))
788                                         (pmap (pad GTYPE "-" prop "-map")))
789                                     (set! index (add1 index))
790                                     `(begin
791                                        (define ,getter
792                                          (lambda (g e)
793                                            (vector-ref
794                                              (,rec-props (cdr e))
795                                              ,index)))
796                                        (define ,setter!
797                                          (lambda (g e p)
798                                            (vector-set!
799                                              (,rec-props (cdr e))
800                                              ,index
801                                              p)))
802                                        (define ,pmap
803                                          (cons ,getter ,setter!)))))
804                                 edge-properties))
805                        (define ,add-directed-edge!
806                          (lambda (g u u-el v)
807                            (let* ((u-tlist (,el-tlist u-el))
808                                   (v-rec (,make-rec v (make-vector ,NP #f))))
809                              (set! u-tlist (cons v-rec u-tlist))
810                              (,set-el-tlist! u-el u-tlist)
811                              (,set-el-tnum! u-el (add1 (,el-tnum u-el)))
812                              (cons u v-rec))))
813                        (define ,remove-directed-edge!
814                          (lambda (g u u-el v)
815                            (let* ((u-tlist (,el-tlist u-el)))
816                              (let find ((tlist u-tlist) (predecessor #f))
817                                (cond ((null? tlist)
818                                       (error "Could not remove directed edge"
819                                              g
820                                              u
821                                              u-el
822                                              v))
823                                      ((,vertex-eq?
824                                        g
825                                        v
826                                        (,rec-target (car tlist)))
827                                       (cond (predecessor
828                                              (set-cdr!
829                                                predecessor
830                                                (cdr tlist)))
831                                             (else
832                                              (,set-el-tlist!
833                                               u-el
834                                               (cdr tlist))))
835                                       (,set-el-tnum!
836                                        u-el
837                                        (sub1 (,el-tnum u-el)))
838                                       #t)
839                                      (else (find (cdr tlist) tlist)))))))
840                        (define ,edge
841                          (lambda (g u v)
842                            (let* ((u-el (,out-edge-list g u))
843                                   (u-tlist (,el-tlist u-el)))
844                              (let find ((tlist u-tlist))
845                                (cond ((null? tlist) #f)
846                                      ((,vertex-eq?
847                                        g
848                                        v
849                                        (,rec-target (car tlist)))
850                                       (cons u (car tlist)))
851                                      (else (find (cdr tlist))))))))
852                        (define ,source (lambda (g e) (car e)))
853                        (define ,target
854                          (lambda (g e) (,rec-target (cdr e))))
855                        (define ,edges
856                          (lambda (g u u-el out?)
857                            (map (lambda (v-rec)
858                                   (if out?
859                                     (cons u v-rec)
860                                     (,edge g (,rec-target v-rec) u)))
861                                 (,el-tlist u-el))))
862                        (define ,edges*
863                          (lambda (g u u-el out?)
864                            (stream-map
865                              (lambda (v-rec)
866                                (if out?
867                                  (cons u v-rec)
868                                  (,edge g (,rec-target v-rec) u)))
869                              (list->stream (,el-tlist u-el)))))
870                        (define ,edge-at
871                          (lambda (g u n)
872                            (let* ((u-el (,out-edge-list g u))
873                                   (u-tlist (,el-tlist u-el))
874                                   (u-tnum (,el-tnum u-el))
875                                   (where (- u-tnum n 1)))
876                              (when (< where)
877                                    (error "Invalid el-slist edge index"))
878                              (cons u (list-ref u-tlist where)))))
879                        (define ,degree
880                          (lambda (g u u-el) (,el-tnum u-el)))
881                        (define ,transform-vertices!
882                          (lambda (proc g u)
883                            (define (x v-rec)
884                              (,set-rec-target!
885                               v-rec
886                               (proc (,rec-target v-rec))))
887                            (for-each x (,el-tlist (,out-edge-list g u)))
888                            ,@(when-bi
889                                `(for-each
890                                   x
891                                   (,el-tlist (,in-edge-list g u)))))))))
892                 args))))
893(when #t
894      (let ((args '(myg () #t #t (edge-weight edge-color))))
895        (printf "~%~a~%" (cons "DEFINE-EL-HASH" args))
896        (pretty-print
897          (apply (lambda (GTYPE
898                          VARGS
899                          streamed?
900                          bidirectional?
901                          edge-properties)
902                   (define (pad . args)
903                     (string->symbol
904                       (apply string-append
905                              (map (lambda (a)
906                                     (cond ((string? a) a)
907                                           ((symbol? a) (symbol->string a))
908                                           (else "UNKNOWN_PAD_SYMBOL")))
909                                   args))))
910                   (define (when-bi . in-args)
911                     (if bidirectional? in-args '()))
912                   (let* ((NP (length edge-properties))
913                          (el (pad GTYPE "-edge-list"))
914                          (el? (gensym))
915                          (make-el (gensym))
916                          (el-thash (gensym))
917                          (set-el-thash! (gensym))
918                          (rec (pad GTYPE "-edge"))
919                          (rec? (gensym))
920                          (make-rec (gensym))
921                          (rec-target (gensym))
922                          (set-rec-target! (gensym))
923                          (rec-props (gensym))
924                          (set-rec-props! (gensym))
925                          (pre-constructor
926                            (pad "##carp#make-" GTYPE "-pre-el"))
927                          (edge-set? (pad GTYPE "-edge-set?"))
928                          (constructor (pad "##carp#make-" GTYPE "-el"))
929                          (add-directed-edge!
930                            (pad "##carp#" GTYPE "-add-directed-edge!"))
931                          (remove-directed-edge!
932                            (pad "##carp#" GTYPE "-remove-directed-edge!"))
933                          (edge (pad GTYPE "-edge"))
934                          (source (pad GTYPE "-source"))
935                          (target (pad GTYPE "-target"))
936                          (edges (pad "##carp#" GTYPE "-edges"))
937                          (edges* (pad "##carp#" GTYPE "-edges*"))
938                          (degree (pad "##carp#" GTYPE "-degree"))
939                          (transform-vertices!
940                            (pad "##carp#" GTYPE "-transform-vertices!"))
941                          (out-edge-list
942                            (pad "##carp#" GTYPE "-out-edge-list"))
943                          (in-edge-list
944                            (pad "##carp#" GTYPE "-in-edge-list"))
945                          (vertex-eq? (pad GTYPE "-vertex-eq?")))
946                     `(begin
947                        (define-macro ,edge-set? (lambda () `#t))
948                        (define-record-type
949                          ,el
950                          (,make-el thash)
951                          ,el?
952                          (thash ,el-thash ,set-el-thash!))
953                        (define-record-printer
954                          ,el
955                          (lambda (x p)
956                            (fprintf p "Edge List el-hash~%")
957                            (fprintf
958                              p
959                              "degree   ~S"
960                              (hash-table-size (,el-thash x)))))
961                        (define-record-type
962                          ,rec
963                          (,make-rec target props)
964                          ,rec?
965                          (target ,rec-target ,set-rec-target!)
966                          (props ,rec-props ,set-rec-props!))
967                        (define-record-printer
968                          ,rec
969                          (lambda (x p)
970                            (fprintf
971                              p
972                              "Edge | target vertex     ~S"
973                              (,rec-target x))))
974                        (define ,pre-constructor
975                          (lambda (g)
976                            (make-hash-table
977                              (lambda (a b) (,vertex-eq? g a b)))))
978                        (define ,constructor
979                          (lambda (g) (,make-el (,pre-constructor g))))
980                        ,@(let ((index -1))
981                            (map (lambda (prop)
982                                   (let ((getter (pad GTYPE "-" prop))
983                                         (setter!
984                                           (pad "set-" GTYPE "-" prop "!"))
985                                         (pmap (pad GTYPE "-" prop "-map")))
986                                     (set! index (add1 index))
987                                     `(begin
988                                        (define ,getter
989                                          (lambda (g e)
990                                            (vector-ref
991                                              (,rec-props (cdr e))
992                                              ,index)))
993                                        (define ,setter!
994                                          (lambda (g e p)
995                                            (vector-set!
996                                              (,rec-props (cdr e))
997                                              ,index
998                                              p)))
999                                        (define ,pmap
1000                                          (cons ,getter ,setter!)))))
1001                                 edge-properties))
1002                        (define ,add-directed-edge!
1003                          (lambda (g u u-el v)
1004                            (let* ((u-thash (,el-thash u-el))
1005                                   (v-rec (hash-table-ref u-thash v)))
1006                              (unless
1007                                v-rec
1008                                (set! v-rec (,make-rec v (make-vector ,NP #f)))
1009                                (hash-table-set! u-thash v v-rec))
1010                              (cons u v-rec))))
1011                        (define ,remove-directed-edge!
1012                          (lambda (g u u-el v)
1013                            (let* ((u-thash (,el-thash u-el)))
1014                              (unless
1015                                (hash-table-delete! u-thash v)
1016                                (error "Could not remove directed edge"
1017                                       g
1018                                       u
1019                                       u-el
1020                                       v)))))
1021                        (define ,edge
1022                          (lambda (g u v)
1023                            (let* ((u-el (,out-edge-list g u))
1024                                   (u-thash (,el-thash u-el))
1025                                   (v-rec (hash-table-ref u-thash v)))
1026                              (and v-rec (cons u v-rec)))))
1027                        (define ,source (lambda (g e) (car e)))
1028                        (define ,target
1029                          (lambda (g e) (,rec-target (cdr e))))
1030                        (define ,edges
1031                          (lambda (g u u-el out?)
1032                            (hash-table-map
1033                              (lambda (v v-rec)
1034                                (if out? (cons u v-rec) (,edge g v u)))
1035                              (,el-thash u-el))))
1036                        (define ,edges*
1037                          (lambda (g u u-el out?)
1038                            (stream-map
1039                              (lambda (v.v-rec)
1040                                (if out?
1041                                  (cons u (cdr v.v-rec))
1042                                  (,edge g (car v.v-rec) u)))
1043                              (hash-table->stream (,el-thash u-el)))))
1044                        (define ,degree
1045                          (lambda (g u u-el)
1046                            (hash-table-size (,el-thash u-el))))
1047                        (define ,transform-vertices!
1048                          (lambda (proc g u)
1049                            (define new-out-thash (,pre-constructor g))
1050                            ,@(when-bi
1051                                `(define new-in-thash (,pre-constructor g)))
1052                            (define (x! new-thash v v-rec)
1053                              (,set-rec-target!
1054                               v-rec
1055                               (proc (,rec-target v-rec)))
1056                              (hash-table-set! new-thash (proc v) v-rec))
1057                            (hash-table-wallk
1058                              (lambda (v v-rec) (x! new-out-thash v v-rec))
1059                              (,el-thash (,out-edge-list g u)))
1060                            (,set-el-thash!
1061                             (,out-edge-list g u)
1062                             new-out-thash)
1063                            ,@(when-bi
1064                                `(hash-table-walk
1065                                   (lambda (v v-rec) (x! new-in-thash v v-rec))
1066                                   (,el-thash (,in-edge-list g u)))
1067                                `(,set-el-thash!
1068                                  (,in-edge-list g u)
1069                                  new-in-thash)))))))
1070                 args))))
Note: See TracBrowser for help on using the repository browser.