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

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

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

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