Changeset 10005 in project


Ignore:
Timestamp:
03/21/08 02:51:13 (13 years ago)
Author:
Kon Lovett
Message:

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

Location:
release/3/rgraph
Files:
14 edited

Legend:

Unmodified
Added
Removed

  • release/3/rgraph/tags/0.3.4/rgraph-base.scm

    r9978 r10005  
    3535(cond-expand
    3636  [chicken
    37     (require-extension extras srfi-69) ; hash-table
    38 
    39     ]
     37    (require-extension srfi-69) ; hash-table
     38    (require-extension srfi-40)]
    4039  (else))
    4140
    4241(cond-expand
    43   [(and chicken (or srfi-40 srfi-41))
     42  [(and chicken srfi-40)
    4443    (define (hash-table->stream ht)
    4544      (##sys#check-structure ht 'hash-table 'hash-table->stream)
    … …  
    5049            (if (fx>= i len)
    5150                lst
    52                 (let loop ([bucket (##sys#slot vec i)] [lst lst])
     51                (let loop ([bucket (##sys#slot vec i)]
     52                           [lst lst])
    5353                  (if (null? bucket)
    5454                      (iter (fx+ i 1) lst)
    … …  
    5959  (else))
    6060
     61#;
    6162(cond-expand
    62   [(or srfi-40 srfi-41)
     63  [(and chicken srfi-40)
     64    (define (hash-table->stream ht)
     65      (stream-delay
     66       (hash-table-fold ht
     67                        (lambda (k v lst) (stream-cons (cons k v) lst))
     68                        stream-null)) ) ]
     69  (else))
     70
     71(cond-expand
     72  [srfi-40
    6373    (define (vector->stream vct)
    6474      (let ([l (vector-length vct)])       
    … …  
    114124  (define vertex-equal?
    115125    (cond [(pair? vertex-eq?) (car vertex-eq?)] [else eq?]))
    116   (define h (make-hash-table vertex-equal?))
     126  (define h (make-hash-table vertex-equal? hash))
    117127  (define vertex-name (graph:get graph 'vertex-name))
    118128  (for-each

  • release/3/rgraph/tags/0.3.4/rgraph-prop.scm

    r9977 r10005  
    6262(define (prop-external-hash eq? . num)
    6363  (let ([store (if (null? num)
    64                    (make-hash-table eq?)
    65                    (make-hash-table eq? (car num)))])
     64                   (make-hash-table eq? hash-by-identity)
     65                   (make-hash-table eq? hash-by-identity (car num)))])
    6666    (cons
    6767     (lambda (g k) (hash-table-ref store k))
    … …  
    7676(define (prop-external-vector . num)
    7777  (let ([store (if (null? num)
    78                    (make-vector)
     78                   (make-vector 0)
    7979                   (make-vector (car num)))])
    8080    (cons
    81      (lambda (g k) (vector-ref store k))
     81     (lambda (g k)
     82       (vector-ref store k))
    8283     (lambda (g k v)
    8384       (when (> k (vector-length store))
    84          (set! store (vector-resize! store (max 2 (* 1.7 k)))))
     85         (set! store (vector-resize store (max 2 (inexact->exact (round (* 1.7 k)))))))
    8586       (vector-set! store k v)))))

  • release/3/rgraph/tags/0.3.4/rgraph-test1.scm

    r9977 r10005  
    103103                          (lambda ()
    104104                            (let* ((pgetters
    105                                      (make-hash-table eq? ,(+ NVP NEP)))
     105                                     (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
    106106                                   (psetters
    107                                      (make-hash-table eq? ,(+ NVP NEP)))
     107                                     (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
    108108                                   (rec (,make-rec #f pgetters psetters)))
    109109                              (,set-rec-vl! rec (,vl-constructor rec))
    … …  
    685685                          (lambda (g)
    686686                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
    687                               (hash-table-map (lambda (k v) k) table))))
     687                              (hash-table-map table (lambda (k v) k)))))
    688688                        (define ,vertices*
    689689                          (lambda (g)
    … …  
    977977                          (lambda (g)
    978978                            (make-hash-table
    979                               (lambda (a b) (,vertex-eq? g a b)))))
     979                              (lambda (a b) (,vertex-eq? g a b))
     980                              hash)))
    980981                        (define ,constructor
    981982                          (lambda (g) (,make-el (,pre-constructor g))))
    … …  
    10331034                          (lambda (g u u-el out?)
    10341035                            (hash-table-map
     1036                              (,el-thash u-el)
    10351037                              (lambda (v v-rec)
    1036                                 (if out? (cons u v-rec) (,edge g v u)))
    1037                               (,el-thash u-el))))
     1038                                (if out? (cons u v-rec) (,edge g v u))))))
    10381039                        (define ,edges*
    10391040                          (lambda (g u u-el out?)
    … …  
    10651066                            ,@(when-bi
    10661067                                `(hash-table-walk
    1067                                    (lambda (v v-rec) (x! new-in-thash v v-rec))
    1068                                    (,el-thash (,in-edge-list g u)))
     1068                                   (,el-thash (,in-edge-list g u))
     1069                                   (lambda (v v-rec) (x! new-in-thash v v-rec)))
    10691070                                `(,set-el-thash!
    10701071                                  (,in-edge-list g u)

  • release/3/rgraph/tags/0.3.4/rgraph-test2.scm

    r9977 r10005  
    3434
    3535(require-extension srfi-40)
     36(register-feature! 'srfi-40)
    3637(cond-expand
    3738  [srfi-40

  • release/3/rgraph/tags/0.3.4/rgraph-test3.scm

    r9977 r10005  
    3434
    3535(require-extension srfi-40)
     36(register-feature! 'srfi-40)
    3637(cond-expand
    3738  [srfi-40

  • release/3/rgraph/tags/0.3.4/rgraph.scm

    r9978 r10005  
    55(define rgraph-doc-usage-imports #t)
    66(define rgraph-doc-usage-debugging #t)
     7
    78(cond-expand
    89  (rgraph-nodebug
     10
    911    (define-macro rgraph-debug (lambda (body) '())))
     12
    1013  ((or rgraph-debug csi)
     14
    1115   (define-macro rgraph-debug (lambda (body) body)))
    12   (else (define-macro rgraph-debug (lambda (body) '()))))
     16
     17  (else
     18
     19   (define-macro rgraph-debug (lambda (body) '()))))
     20
    1321(define rgraph-doc-adjacency-list #t)
     22
    1423(define-macro
    1524  define-adjacency-list
    … …  
    2231           directed?
    2332           bidirectional?)
     33
    2434    (define (pad . args)
    2535      (string->symbol
    … …  
    3040                            (else "UNKNOWN_PAD_SYMBOL")))
    3141                    args))))
     42
    3243    (define (when-bi . in-args)
    3344      (if bidirectional? in-args '()))
     45
    3446    (define (when-bi-or-dir . in-args)
    3547      (if (or bidirectional? directed?) in-args '()))
     48
    3649    (let* ((NVP (length vertex-properties))
    3750           (NEP (length edge-properties))
    … …  
    103116         (define ,constructor
    104117           (lambda ()
    105              (let* ((pgetters (make-hash-table eq? ,(+ NVP NEP)))
    106                     (psetters (make-hash-table eq? ,(+ NVP NEP)))
     118             (let* ((pgetters (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
     119                    (psetters (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
    107120                    (rec (,make-rec #f pgetters psetters)))
    108121               (,set-rec-vl! rec (,vl-constructor rec))
    … …  
    199212                    ,bidirectional?))
    200213                algorithms)))))
     214
    201215(define rgraph-doc-vl-vector #t)
     216
    202217(define-macro
    203218  define-vl-vector
    … …  
    208223           vertex-properties
    209224           get-vl)
     225
    210226    (define (pad . args)
    211227      (string->symbol
    … …  
    216232                            (else "UNKNOWN_PAD_SYMBOL")))
    217233                    args))))
     234
    218235    (define plus (if streamed? "*" ""))
     236
    219237    (define prefix-plus (if streamed? "stream-" ""))
     238
    220239    (define (when-bi . in-args)
    221240      (if bidirectional? in-args '()))
     241
    222242    (define (unless-bi . in-args)
    223243      (if bidirectional? '() in-args))
     244
    224245    (let* ((for-each+ (pad prefix-plus "for-each"))
    225246           (map+ (pad prefix-plus "map"))
    … …  
    432453               (,set-vl-num! vl 0)
    433454               (,set-vl-vec! vl (make-vector 0)))))))))
     455
    434456(define rgraph-doc-vl-hash #t)
     457
    435458(define-macro
    436459  define-vl-hash
    … …  
    441464           vertex-properties
    442465           get-vl)
     466
    443467    (define (pad . args)
    444468      (string->symbol
    … …  
    449473                            (else "UNKNOWN_PAD_SYMBOL")))
    450474                    args))))
     475
    451476    (define plus (if streamed? "*" ""))
     477
    452478    (define prefix-plus (if streamed? "stream-" ""))
     479
    453480    (define (when-bi . in-args)
    454481      (if bidirectional? in-args '()))
     482
    455483    (define (unless-bi . in-args)
    456484      (if bidirectional? '() in-args))
     485
    457486    (let* ((for-each+ (pad prefix-plus "for-each"))
    458487           (map+ (pad prefix-plus "map"))
    … …  
    600629                      (let ((v^u (,edge g v u)))
    601630                        (when v^u (,remove-edge! g v^u)))))
    602                (hash-table-remove! table u))))
     631               (hash-table-delete! table u))))
    603632         (define ,vertex-eq?
    604633           (lambda (g u v)
    … …  
    635664           (lambda (g)
    636665             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
     666               #;(hash-table-clear! table)
    637667               (##sys#setslot table 1 (make-vector (##sys#size (##sys#slot table 1)) '())))))))))
     668
    638669(define rgraph-doc-el-slist #t)
     670
    639671(define-macro
    640672  define-el-slist
    … …  
    644676           bidirectional?
    645677           edge-properties)
     678
    646679    (define (pad . args)
    647680      (string->symbol
    … …  
    652685                            (else "UNKNOWN_PAD_SYMBOL")))
    653686                    args))))
     687
    654688    (define (when-bi . in-args)
    655689      (if bidirectional? in-args '()))
     690
    656691    (let* ((NP (length edge-properties))
    657692           (el (pad GTYPE "-edge-list"))
    … …  
    803838             ,@(when-bi
    804839                 `(for-each x (,el-tlist (,in-edge-list g u))))))))))
     840
    805841(define rgraph-doc-el-hash #t)
     842
    806843(define-macro
    807844  define-el-hash
    … …  
    811848           bidirectional?
    812849           edge-properties)
     850
    813851    (define (pad . args)
    814852      (string->symbol
    … …  
    819857                            (else "UNKNOWN_PAD_SYMBOL")))
    820858                    args))))
     859
    821860    (define (when-bi . in-args)
    822861      (if bidirectional? in-args '()))
     862
    823863    (let* ((NP (length edge-properties))
    824864           (el (pad GTYPE "-edge-list"))
    … …  
    886926           (lambda (g)
    887927             (make-hash-table
    888                (lambda (a b) (,vertex-eq? g a b)))))
     928               (lambda (a b) (,vertex-eq? g a b))
     929               hash)))
    889930         (define ,constructor
    890931           (lambda (g) (,make-el (,pre-constructor g))))
    … …  
    917958             (let* ((u-thash (,el-thash u-el)))
    918959               (unless
    919                  (hash-table-remove! u-thash v)
     960                 (hash-table-delete! u-thash v)
    920961                 (error "Could not remove directed edge"
    921962                        g
    … …  
    935976           (lambda (g u u-el out?)
    936977             (hash-table-map
     978               (,el-thash u-el)
    937979               (lambda (v v-rec)
    938                  (if out? (cons u v-rec) (,edge g v u)))
    939                (,el-thash u-el))))
     980                 (if out? (cons u v-rec) (,edge g v u))))))
    940981         (define ,edges*
    941982           (lambda (g u u-el out?)
    … …  
    9601001               (hash-table-set! new-thash (proc v) v-rec))
    9611002             (hash-table-walk
    962                (lambda (v v-rec) (x! new-out-thash v v-rec))
    963                (,el-thash (,out-edge-list g u)))
     1003               (,el-thash (,out-edge-list g u))
     1004               (lambda (v v-rec) (x! new-out-thash v v-rec)))
    9641005             (,set-el-thash!
    9651006              (,out-edge-list g u)
    … …  
    9671008             ,@(when-bi
    9681009                 `(hash-table-walk
    969                     (lambda (v v-rec) (x! new-in-thash v v-rec))
    970                     (,el-thash (,in-edge-list g u)))
     1010                    (,el-thash (,in-edge-list g u))
     1011                    (lambda (v v-rec) (x! new-in-thash v v-rec)))
    9711012                 `(,set-el-thash! (,in-edge-list g u) new-in-thash))))))))
     1013
    9721014(define rgraph-doc-visitors #t)
    9731015(define rgraph-doc-properties #t)
    9741016(define rgraph-doc-let-rgraph #t)
     1017
    9751018(define-macro
    9761019  let-rgraph
    9771020  (lambda (GTYPE . rest)
     1021
    9781022    (define plus
    9791023      (cond-expand (srfi-40 "*") (else "")))
     1024
    9801025    (define prefix-plus
    9811026      (cond-expand (srfi-40 "stream-") (else "")))
     1027
    9821028    (define (pad . args)
    9831029      (string->symbol
    … …  
    9881034                            (else "UNKNOWN_PAD_SYMBOL")))
    9891035                    args))))
     1036
    9901037    (let ((for-each+ (pad prefix-plus "for-each"))
    9911038          (map+ (pad prefix-plus "map"))
    … …  
    10451092             (edge-at ,edge-at))
    10461093         ,@rest))))
     1094
    10471095(define rgraph-doc-fill-graph! #t)
     1096
    10481097(define-macro
    10491098  (import-fill-graph!
    … …  
    10541103    directed?
    10551104    bidirectional?)
     1105
    10561106  (define (pad . args)
    10571107    (string->symbol
    … …  
    10621112                          (else "UNKNOWN_PAD_SYMBOL")))
    10631113                  args))))
     1114
    10641115  (define (when-bi . in-args)
    10651116    (if bidirectional? in-args '()))
     1117
    10661118  (let ((algorithm (pad GTYPE "-fill-graph!"))
    10671119        (vertex-eq? (pad GTYPE "-vertex-eq?"))
    … …  
    10901142           edges)
    10911143         g))))
     1144
    10921145(define rgraph-doc-dfs #t)
    1093 (define rgraph-doc-dfs #t)
     1146
    10941147(define-macro
    10951148  (import-depth-first-search
    … …  
    11001153    directed?
    11011154    bidirectional?)
     1155
    11021156  (define (pad . args)
    11031157    (string->symbol
    … …  
    11081162                          (else "UNKNOWN_PAD_SYMBOL")))
    11091163                  args))))
     1164
    11101165  (define (when-bi . in-args)
    11111166    (if bidirectional? in-args '()))
     1167
    11121168  `(begin
    11131169     ,@(map (lambda (streamed?)
    … …  
    11871243                              #f)))))))
    11881244            (if streamed? (list #f #t) (list #f)))))
     1245
    11891246(define rgraph-doc-dfv #t)
     1247
    11901248(define-macro
    11911249  (import-depth-first-visit
    … …  
    11961254    directed?
    11971255    bidirectional?)
     1256
     1257  (define (pad . args)
     1258    (string->symbol
     1259      (apply string-append
     1260             (map (lambda (a)
     1261                    (cond ((string? a) a)
     1262                          ((symbol? a) (symbol->string a))
     1263                          (else "UNKNOWN_PAD_SYMBOL")))
     1264                  args))))
     1265
    11981266  `(begin
    11991267     ,@(map (lambda (streamed?)
    … …  
    12041272                    (depth-first-search+
    12051273                      (pad GTYPE "-depth-first-search" plus)))
    1206                 `(define ,algorithm
     1274                `(define ,algorithm+
    12071275                   (lambda (g dfs-visitor color-map u)
    12081276                     (,depth-first-search+
    … …  
    12121280                      (cons 'depth-first-visit u))))))
    12131281            (if streamed? (list #f #t) (list #f)))))
    1214 (define rgraph-doc-topsort #t)
     1282
    12151283(define rgraph-doc-topsort #t)
    12161284(define rgraph-doc-topsort* #t)
     1285
    12171286(define-macro
    12181287  (import-topological-sort
    … …  
    12231292    directed?
    12241293    bidirectional?)
     1294
    12251295  (define (pad . args)
    12261296    (string->symbol
    … …  
    12311301                          (else "UNKNOWN_PAD_SYMBOL")))
    12321302                  args))))
     1303
    12331304  `(begin
    12341305     ,@(map (lambda (streamed?)
    … …  
    13051376                         `first)))))
    13061377            (if streamed? (list #f #t) (list #f)))))
     1378
    13071379(define rgraph-doc-part-fidmat #t)
    13081380(define fidmat-check #t)
    13091381(define fidmat-debug #t)
     1382
    13101383(define-record partition-fm cost balance vertex)
     1384
    13111385(define-macro
    13121386  (import-partition-fidmat
    … …  
    13171391    directed?
    13181392    bidirectional?)
     1393
    13191394  (define (pad . args)
    13201395    (string->symbol
    … …  
    13251400                          (else "UNKNOWN_PAD_SYMBOL")))
    13261401                  args))))
     1402
    13271403  (define (when-bi . in-args)
    13281404    (if bidirectional? in-args '()))
     1405
    13291406  (define check
    13301407    (pad GTYPE "-partition-fidmat-check"))
     1408
    13311409  (define debug
    13321410    (pad GTYPE "-partition-fidmat-debug"))
     1411
    13331412  `(begin
    13341413     (define ,check #f)
    … …  
    15551634                                      (loop1 c))))))))))))
    15561635            (if streamed? (list #f #t) (list #f)))))
     1636
    15571637(define rgraph-doc-partition-fidmat-check #t)
    15581638(define rgraph-doc-partition-fidmat-debug #t)

  • release/3/rgraph/tags/0.3.4/rgraph.setup

    r9978 r10005  
    11;;;; rgraph.setup -*- Hen -*-
    22
    3 (compile -s -O2 -d0 -check-imports -emit-exports "rgraph.exports" rgraph-base.scm -check-imports)
     3(compile -s -O2 -d0 -Dsrfi-40 -check-imports -emit-exports "rgraph.exports" rgraph-base.scm -check-imports)
    44
    55(install-extension

  • release/3/rgraph/trunk/rgraph-base.scm

    r9978 r10005  
    3535(cond-expand
    3636  [chicken
    37     (require-extension extras srfi-69) ; hash-table
    38 
    39     ]
     37    (require-extension srfi-69) ; hash-table
     38    (require-extension srfi-40)]
    4039  (else))
    4140
    4241(cond-expand
    43   [(and chicken (or srfi-40 srfi-41))
     42  [(and chicken srfi-40)
    4443    (define (hash-table->stream ht)
    4544      (##sys#check-structure ht 'hash-table 'hash-table->stream)
    … …  
    5049            (if (fx>= i len)
    5150                lst
    52                 (let loop ([bucket (##sys#slot vec i)] [lst lst])
     51                (let loop ([bucket (##sys#slot vec i)]
     52                           [lst lst])
    5353                  (if (null? bucket)
    5454                      (iter (fx+ i 1) lst)
    … …  
    5959  (else))
    6060
     61#;
    6162(cond-expand
    62   [(or srfi-40 srfi-41)
     63  [(and chicken srfi-40)
     64    (define (hash-table->stream ht)
     65      (stream-delay
     66       (hash-table-fold ht
     67                        (lambda (k v lst) (stream-cons (cons k v) lst))
     68                        stream-null)) ) ]
     69  (else))
     70
     71(cond-expand
     72  [srfi-40
    6373    (define (vector->stream vct)
    6474      (let ([l (vector-length vct)])       
    … …  
    114124  (define vertex-equal?
    115125    (cond [(pair? vertex-eq?) (car vertex-eq?)] [else eq?]))
    116   (define h (make-hash-table vertex-equal?))
     126  (define h (make-hash-table vertex-equal? hash))
    117127  (define vertex-name (graph:get graph 'vertex-name))
    118128  (for-each

  • release/3/rgraph/trunk/rgraph-prop.scm

    r9977 r10005  
    6262(define (prop-external-hash eq? . num)
    6363  (let ([store (if (null? num)
    64                    (make-hash-table eq?)
    65                    (make-hash-table eq? (car num)))])
     64                   (make-hash-table eq? hash-by-identity)
     65                   (make-hash-table eq? hash-by-identity (car num)))])
    6666    (cons
    6767     (lambda (g k) (hash-table-ref store k))
    … …  
    7676(define (prop-external-vector . num)
    7777  (let ([store (if (null? num)
    78                    (make-vector)
     78                   (make-vector 0)
    7979                   (make-vector (car num)))])
    8080    (cons
    81      (lambda (g k) (vector-ref store k))
     81     (lambda (g k)
     82       (vector-ref store k))
    8283     (lambda (g k v)
    8384       (when (> k (vector-length store))
    84          (set! store (vector-resize! store (max 2 (* 1.7 k)))))
     85         (set! store (vector-resize store (max 2 (inexact->exact (round (* 1.7 k)))))))
    8586       (vector-set! store k v)))))

  • release/3/rgraph/trunk/rgraph-test1.scm

    r9977 r10005  
    103103                          (lambda ()
    104104                            (let* ((pgetters
    105                                      (make-hash-table eq? ,(+ NVP NEP)))
     105                                     (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
    106106                                   (psetters
    107                                      (make-hash-table eq? ,(+ NVP NEP)))
     107                                     (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
    108108                                   (rec (,make-rec #f pgetters psetters)))
    109109                              (,set-rec-vl! rec (,vl-constructor rec))
    … …  
    685685                          (lambda (g)
    686686                            (let* ((vl (,get-vl g)) (table (,vl-table vl)))
    687                               (hash-table-map (lambda (k v) k) table))))
     687                              (hash-table-map table (lambda (k v) k)))))
    688688                        (define ,vertices*
    689689                          (lambda (g)
    … …  
    977977                          (lambda (g)
    978978                            (make-hash-table
    979                               (lambda (a b) (,vertex-eq? g a b)))))
     979                              (lambda (a b) (,vertex-eq? g a b))
     980                              hash)))
    980981                        (define ,constructor
    981982                          (lambda (g) (,make-el (,pre-constructor g))))
    … …  
    10331034                          (lambda (g u u-el out?)
    10341035                            (hash-table-map
     1036                              (,el-thash u-el)
    10351037                              (lambda (v v-rec)
    1036                                 (if out? (cons u v-rec) (,edge g v u)))
    1037                               (,el-thash u-el))))
     1038                                (if out? (cons u v-rec) (,edge g v u))))))
    10381039                        (define ,edges*
    10391040                          (lambda (g u u-el out?)
    … …  
    10651066                            ,@(when-bi
    10661067                                `(hash-table-walk
    1067                                    (lambda (v v-rec) (x! new-in-thash v v-rec))
    1068                                    (,el-thash (,in-edge-list g u)))
     1068                                   (,el-thash (,in-edge-list g u))
     1069                                   (lambda (v v-rec) (x! new-in-thash v v-rec)))
    10691070                                `(,set-el-thash!
    10701071                                  (,in-edge-list g u)

  • release/3/rgraph/trunk/rgraph-test2.scm

    r9977 r10005  
    3434
    3535(require-extension srfi-40)
     36(register-feature! 'srfi-40)
    3637(cond-expand
    3738  [srfi-40

  • release/3/rgraph/trunk/rgraph-test3.scm

    r9977 r10005  
    3434
    3535(require-extension srfi-40)
     36(register-feature! 'srfi-40)
    3637(cond-expand
    3738  [srfi-40

  • release/3/rgraph/trunk/rgraph.scm

    r9978 r10005  
    55(define rgraph-doc-usage-imports #t)
    66(define rgraph-doc-usage-debugging #t)
     7
    78(cond-expand
    89  (rgraph-nodebug
     10
    911    (define-macro rgraph-debug (lambda (body) '())))
     12
    1013  ((or rgraph-debug csi)
     14
    1115   (define-macro rgraph-debug (lambda (body) body)))
    12   (else (define-macro rgraph-debug (lambda (body) '()))))
     16
     17  (else
     18
     19   (define-macro rgraph-debug (lambda (body) '()))))
     20
    1321(define rgraph-doc-adjacency-list #t)
     22
    1423(define-macro
    1524  define-adjacency-list
    … …  
    2231           directed?
    2332           bidirectional?)
     33
    2434    (define (pad . args)
    2535      (string->symbol
    … …  
    3040                            (else "UNKNOWN_PAD_SYMBOL")))
    3141                    args))))
     42
    3243    (define (when-bi . in-args)
    3344      (if bidirectional? in-args '()))
     45
    3446    (define (when-bi-or-dir . in-args)
    3547      (if (or bidirectional? directed?) in-args '()))
     48
    3649    (let* ((NVP (length vertex-properties))
    3750           (NEP (length edge-properties))
    … …  
    103116         (define ,constructor
    104117           (lambda ()
    105              (let* ((pgetters (make-hash-table eq? ,(+ NVP NEP)))
    106                     (psetters (make-hash-table eq? ,(+ NVP NEP)))
     118             (let* ((pgetters (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
     119                    (psetters (make-hash-table eq? hash-by-identity ,(+ NVP NEP)))
    107120                    (rec (,make-rec #f pgetters psetters)))
    108121               (,set-rec-vl! rec (,vl-constructor rec))
    … …  
    199212                    ,bidirectional?))
    200213                algorithms)))))
     214
    201215(define rgraph-doc-vl-vector #t)
     216
    202217(define-macro
    203218  define-vl-vector
    … …  
    208223           vertex-properties
    209224           get-vl)
     225
    210226    (define (pad . args)
    211227      (string->symbol
    … …  
    216232                            (else "UNKNOWN_PAD_SYMBOL")))
    217233                    args))))
     234
    218235    (define plus (if streamed? "*" ""))
     236
    219237    (define prefix-plus (if streamed? "stream-" ""))
     238
    220239    (define (when-bi . in-args)
    221240      (if bidirectional? in-args '()))
     241
    222242    (define (unless-bi . in-args)
    223243      (if bidirectional? '() in-args))
     244
    224245    (let* ((for-each+ (pad prefix-plus "for-each"))
    225246           (map+ (pad prefix-plus "map"))
    … …  
    432453               (,set-vl-num! vl 0)
    433454               (,set-vl-vec! vl (make-vector 0)))))))))
     455
    434456(define rgraph-doc-vl-hash #t)
     457
    435458(define-macro
    436459  define-vl-hash
    … …  
    441464           vertex-properties
    442465           get-vl)
     466
    443467    (define (pad . args)
    444468      (string->symbol
    … …  
    449473                            (else "UNKNOWN_PAD_SYMBOL")))
    450474                    args))))
     475
    451476    (define plus (if streamed? "*" ""))
     477
    452478    (define prefix-plus (if streamed? "stream-" ""))
     479
    453480    (define (when-bi . in-args)
    454481      (if bidirectional? in-args '()))
     482
    455483    (define (unless-bi . in-args)
    456484      (if bidirectional? '() in-args))
     485
    457486    (let* ((for-each+ (pad prefix-plus "for-each"))
    458487           (map+ (pad prefix-plus "map"))
    … …  
    600629                      (let ((v^u (,edge g v u)))
    601630                        (when v^u (,remove-edge! g v^u)))))
    602                (hash-table-remove! table u))))
     631               (hash-table-delete! table u))))
    603632         (define ,vertex-eq?
    604633           (lambda (g u v)
    … …  
    635664           (lambda (g)
    636665             (let* ((vl (,get-vl g)) (table (,vl-table vl)))
     666               #;(hash-table-clear! table)
    637667               (##sys#setslot table 1 (make-vector (##sys#size (##sys#slot table 1)) '())))))))))
     668
    638669(define rgraph-doc-el-slist #t)
     670
    639671(define-macro
    640672  define-el-slist
    … …  
    644676           bidirectional?
    645677           edge-properties)
     678
    646679    (define (pad . args)
    647680      (string->symbol
    … …  
    652685                            (else "UNKNOWN_PAD_SYMBOL")))
    653686                    args))))
     687
    654688    (define (when-bi . in-args)
    655689      (if bidirectional? in-args '()))
     690
    656691    (let* ((NP (length edge-properties))
    657692           (el (pad GTYPE "-edge-list"))
    … …  
    803838             ,@(when-bi
    804839                 `(for-each x (,el-tlist (,in-edge-list g u))))))))))
     840
    805841(define rgraph-doc-el-hash #t)
     842
    806843(define-macro
    807844  define-el-hash
    … …  
    811848           bidirectional?
    812849           edge-properties)
     850
    813851    (define (pad . args)
    814852      (string->symbol
    … …  
    819857                            (else "UNKNOWN_PAD_SYMBOL")))
    820858                    args))))
     859
    821860    (define (when-bi . in-args)
    822861      (if bidirectional? in-args '()))
     862
    823863    (let* ((NP (length edge-properties))
    824864           (el (pad GTYPE "-edge-list"))
    … …  
    886926           (lambda (g)
    887927             (make-hash-table
    888                (lambda (a b) (,vertex-eq? g a b)))))
     928               (lambda (a b) (,vertex-eq? g a b))
     929               hash)))
    889930         (define ,constructor
    890931           (lambda (g) (,make-el (,pre-constructor g))))
    … …  
    917958             (let* ((u-thash (,el-thash u-el)))
    918959               (unless
    919                  (hash-table-remove! u-thash v)
     960                 (hash-table-delete! u-thash v)
    920961                 (error "Could not remove directed edge"
    921962                        g
    … …  
    935976           (lambda (g u u-el out?)
    936977             (hash-table-map
     978               (,el-thash u-el)
    937979               (lambda (v v-rec)
    938                  (if out? (cons u v-rec) (,edge g v u)))
    939                (,el-thash u-el))))
     980                 (if out? (cons u v-rec) (,edge g v u))))))
    940981         (define ,edges*
    941982           (lambda (g u u-el out?)
    … …  
    9601001               (hash-table-set! new-thash (proc v) v-rec))
    9611002             (hash-table-walk
    962                (lambda (v v-rec) (x! new-out-thash v v-rec))
    963                (,el-thash (,out-edge-list g u)))
     1003               (,el-thash (,out-edge-list g u))
     1004               (lambda (v v-rec) (x! new-out-thash v v-rec)))
    9641005             (,set-el-thash!
    9651006              (,out-edge-list g u)
    … …  
    9671008             ,@(when-bi
    9681009                 `(hash-table-walk
    969                     (lambda (v v-rec) (x! new-in-thash v v-rec))
    970                     (,el-thash (,in-edge-list g u)))
     1010                    (,el-thash (,in-edge-list g u))
     1011                    (lambda (v v-rec) (x! new-in-thash v v-rec)))
    9711012                 `(,set-el-thash! (,in-edge-list g u) new-in-thash))))))))
     1013
    9721014(define rgraph-doc-visitors #t)
    9731015(define rgraph-doc-properties #t)
    9741016(define rgraph-doc-let-rgraph #t)
     1017
    9751018(define-macro
    9761019  let-rgraph
    9771020  (lambda (GTYPE . rest)
     1021
    9781022    (define plus
    9791023      (cond-expand (srfi-40 "*") (else "")))
     1024
    9801025    (define prefix-plus
    9811026      (cond-expand (srfi-40 "stream-") (else "")))
     1027
    9821028    (define (pad . args)
    9831029      (string->symbol
    … …  
    9881034                            (else "UNKNOWN_PAD_SYMBOL")))
    9891035                    args))))
     1036
    9901037    (let ((for-each+ (pad prefix-plus "for-each"))
    9911038          (map+ (pad prefix-plus "map"))
    … …  
    10451092             (edge-at ,edge-at))
    10461093         ,@rest))))
     1094
    10471095(define rgraph-doc-fill-graph! #t)
     1096
    10481097(define-macro
    10491098  (import-fill-graph!
    … …  
    10541103    directed?
    10551104    bidirectional?)
     1105
    10561106  (define (pad . args)
    10571107    (string->symbol
    … …  
    10621112                          (else "UNKNOWN_PAD_SYMBOL")))
    10631113                  args))))
     1114
    10641115  (define (when-bi . in-args)
    10651116    (if bidirectional? in-args '()))
     1117
    10661118  (let ((algorithm (pad GTYPE "-fill-graph!"))
    10671119        (vertex-eq? (pad GTYPE "-vertex-eq?"))
    … …  
    10901142           edges)
    10911143         g))))
     1144
    10921145(define rgraph-doc-dfs #t)
    1093 (define rgraph-doc-dfs #t)
     1146
    10941147(define-macro
    10951148  (import-depth-first-search
    … …  
    11001153    directed?
    11011154    bidirectional?)
     1155
    11021156  (define (pad . args)
    11031157    (string->symbol
    … …  
    11081162                          (else "UNKNOWN_PAD_SYMBOL")))
    11091163                  args))))
     1164
    11101165  (define (when-bi . in-args)
    11111166    (if bidirectional? in-args '()))
     1167
    11121168  `(begin
    11131169     ,@(map (lambda (streamed?)
    … …  
    11871243                              #f)))))))
    11881244            (if streamed? (list #f #t) (list #f)))))
     1245
    11891246(define rgraph-doc-dfv #t)
     1247
    11901248(define-macro
    11911249  (import-depth-first-visit
    … …  
    11961254    directed?
    11971255    bidirectional?)
     1256
     1257  (define (pad . args)
     1258    (string->symbol
     1259      (apply string-append
     1260             (map (lambda (a)
     1261                    (cond ((string? a) a)
     1262                          ((symbol? a) (symbol->string a))
     1263                          (else "UNKNOWN_PAD_SYMBOL")))
     1264                  args))))
     1265
    11981266  `(begin
    11991267     ,@(map (lambda (streamed?)
    … …  
    12041272                    (depth-first-search+
    12051273                      (pad GTYPE "-depth-first-search" plus)))
    1206                 `(define ,algorithm
     1274                `(define ,algorithm+
    12071275                   (lambda (g dfs-visitor color-map u)
    12081276                     (,depth-first-search+
    … …  
    12121280                      (cons 'depth-first-visit u))))))
    12131281            (if streamed? (list #f #t) (list #f)))))
    1214 (define rgraph-doc-topsort #t)
     1282
    12151283(define rgraph-doc-topsort #t)
    12161284(define rgraph-doc-topsort* #t)
     1285
    12171286(define-macro
    12181287  (import-topological-sort
    … …  
    12231292    directed?
    12241293    bidirectional?)
     1294
    12251295  (define (pad . args)
    12261296    (string->symbol
    … …  
    12311301                          (else "UNKNOWN_PAD_SYMBOL")))
    12321302                  args))))
     1303
    12331304  `(begin
    12341305     ,@(map (lambda (streamed?)
    … …  
    13051376                         `first)))))
    13061377            (if streamed? (list #f #t) (list #f)))))
     1378
    13071379(define rgraph-doc-part-fidmat #t)
    13081380(define fidmat-check #t)
    13091381(define fidmat-debug #t)
     1382
    13101383(define-record partition-fm cost balance vertex)
     1384
    13111385(define-macro
    13121386  (import-partition-fidmat
    … …  
    13171391    directed?
    13181392    bidirectional?)
     1393
    13191394  (define (pad . args)
    13201395    (string->symbol
    … …  
    13251400                          (else "UNKNOWN_PAD_SYMBOL")))
    13261401                  args))))
     1402
    13271403  (define (when-bi . in-args)
    13281404    (if bidirectional? in-args '()))
     1405
    13291406  (define check
    13301407    (pad GTYPE "-partition-fidmat-check"))
     1408
    13311409  (define debug
    13321410    (pad GTYPE "-partition-fidmat-debug"))
     1411
    13331412  `(begin
    13341413     (define ,check #f)
    … …  
    15551634                                      (loop1 c))))))))))))
    15561635            (if streamed? (list #f #t) (list #f)))))
     1636
    15571637(define rgraph-doc-partition-fidmat-check #t)
    15581638(define rgraph-doc-partition-fidmat-debug #t)

  • release/3/rgraph/trunk/rgraph.setup

    r9978 r10005  
    11;;;; rgraph.setup -*- Hen -*-
    22
    3 (compile -s -O2 -d0 -check-imports -emit-exports "rgraph.exports" rgraph-base.scm -check-imports)
     3(compile -s -O2 -d0 -Dsrfi-40 -check-imports -emit-exports "rgraph.exports" rgraph-base.scm -check-imports)
    44
    55(install-extension
Note: See TracChangeset for help on using the changeset viewer.