Changeset 10005 in project
- Timestamp:
- 03/21/08 02:51:13 (13 years ago)
- Location:
- release/3/rgraph
- Files:
-
- 14 edited
Legend:
- Unmodified
- Added
- Removed
-
release/3/rgraph/tags/0.3.4/rgraph-base.scm
r9978 r10005 35 35 (cond-expand 36 36 [chicken 37 (require-extension extras srfi-69) ; hash-table 38 39 ] 37 (require-extension srfi-69) ; hash-table 38 (require-extension srfi-40)] 40 39 (else)) 41 40 42 41 (cond-expand 43 [(and chicken (or srfi-40 srfi-41))42 [(and chicken srfi-40) 44 43 (define (hash-table->stream ht) 45 44 (##sys#check-structure ht 'hash-table 'hash-table->stream) … … 50 49 (if (fx>= i len) 51 50 lst 52 (let loop ([bucket (##sys#slot vec i)] [lst lst]) 51 (let loop ([bucket (##sys#slot vec i)] 52 [lst lst]) 53 53 (if (null? bucket) 54 54 (iter (fx+ i 1) lst) … … 59 59 (else)) 60 60 61 #; 61 62 (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 63 73 (define (vector->stream vct) 64 74 (let ([l (vector-length vct)]) … … 114 124 (define vertex-equal? 115 125 (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)) 117 127 (define vertex-name (graph:get graph 'vertex-name)) 118 128 (for-each -
release/3/rgraph/tags/0.3.4/rgraph-prop.scm
r9977 r10005 62 62 (define (prop-external-hash eq? . num) 63 63 (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)))]) 66 66 (cons 67 67 (lambda (g k) (hash-table-ref store k)) … … 76 76 (define (prop-external-vector . num) 77 77 (let ([store (if (null? num) 78 (make-vector )78 (make-vector 0) 79 79 (make-vector (car num)))]) 80 80 (cons 81 (lambda (g k) (vector-ref store k)) 81 (lambda (g k) 82 (vector-ref store k)) 82 83 (lambda (g k v) 83 84 (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))))))) 85 86 (vector-set! store k v))))) -
release/3/rgraph/tags/0.3.4/rgraph-test1.scm
r9977 r10005 103 103 (lambda () 104 104 (let* ((pgetters 105 (make-hash-table eq? ,(+ NVP NEP)))105 (make-hash-table eq? hash-by-identity ,(+ NVP NEP))) 106 106 (psetters 107 (make-hash-table eq? ,(+ NVP NEP)))107 (make-hash-table eq? hash-by-identity ,(+ NVP NEP))) 108 108 (rec (,make-rec #f pgetters psetters))) 109 109 (,set-rec-vl! rec (,vl-constructor rec)) … … 685 685 (lambda (g) 686 686 (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))))) 688 688 (define ,vertices* 689 689 (lambda (g) … … 977 977 (lambda (g) 978 978 (make-hash-table 979 (lambda (a b) (,vertex-eq? g a b))))) 979 (lambda (a b) (,vertex-eq? g a b)) 980 hash))) 980 981 (define ,constructor 981 982 (lambda (g) (,make-el (,pre-constructor g)))) … … 1033 1034 (lambda (g u u-el out?) 1034 1035 (hash-table-map 1036 (,el-thash u-el) 1035 1037 (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)))))) 1038 1039 (define ,edges* 1039 1040 (lambda (g u u-el out?) … … 1065 1066 ,@(when-bi 1066 1067 `(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))) 1069 1070 `(,set-el-thash! 1070 1071 (,in-edge-list g u) -
release/3/rgraph/tags/0.3.4/rgraph-test2.scm
r9977 r10005 34 34 35 35 (require-extension srfi-40) 36 (register-feature! 'srfi-40) 36 37 (cond-expand 37 38 [srfi-40 -
release/3/rgraph/tags/0.3.4/rgraph-test3.scm
r9977 r10005 34 34 35 35 (require-extension srfi-40) 36 (register-feature! 'srfi-40) 36 37 (cond-expand 37 38 [srfi-40 -
release/3/rgraph/tags/0.3.4/rgraph.scm
r9978 r10005 5 5 (define rgraph-doc-usage-imports #t) 6 6 (define rgraph-doc-usage-debugging #t) 7 7 8 (cond-expand 8 9 (rgraph-nodebug 10 9 11 (define-macro rgraph-debug (lambda (body) '()))) 12 10 13 ((or rgraph-debug csi) 14 11 15 (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 13 21 (define rgraph-doc-adjacency-list #t) 22 14 23 (define-macro 15 24 define-adjacency-list … … 22 31 directed? 23 32 bidirectional?) 33 24 34 (define (pad . args) 25 35 (string->symbol … … 30 40 (else "UNKNOWN_PAD_SYMBOL"))) 31 41 args)))) 42 32 43 (define (when-bi . in-args) 33 44 (if bidirectional? in-args '())) 45 34 46 (define (when-bi-or-dir . in-args) 35 47 (if (or bidirectional? directed?) in-args '())) 48 36 49 (let* ((NVP (length vertex-properties)) 37 50 (NEP (length edge-properties)) … … 103 116 (define ,constructor 104 117 (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))) 107 120 (rec (,make-rec #f pgetters psetters))) 108 121 (,set-rec-vl! rec (,vl-constructor rec)) … … 199 212 ,bidirectional?)) 200 213 algorithms))))) 214 201 215 (define rgraph-doc-vl-vector #t) 216 202 217 (define-macro 203 218 define-vl-vector … … 208 223 vertex-properties 209 224 get-vl) 225 210 226 (define (pad . args) 211 227 (string->symbol … … 216 232 (else "UNKNOWN_PAD_SYMBOL"))) 217 233 args)))) 234 218 235 (define plus (if streamed? "*" "")) 236 219 237 (define prefix-plus (if streamed? "stream-" "")) 238 220 239 (define (when-bi . in-args) 221 240 (if bidirectional? in-args '())) 241 222 242 (define (unless-bi . in-args) 223 243 (if bidirectional? '() in-args)) 244 224 245 (let* ((for-each+ (pad prefix-plus "for-each")) 225 246 (map+ (pad prefix-plus "map")) … … 432 453 (,set-vl-num! vl 0) 433 454 (,set-vl-vec! vl (make-vector 0))))))))) 455 434 456 (define rgraph-doc-vl-hash #t) 457 435 458 (define-macro 436 459 define-vl-hash … … 441 464 vertex-properties 442 465 get-vl) 466 443 467 (define (pad . args) 444 468 (string->symbol … … 449 473 (else "UNKNOWN_PAD_SYMBOL"))) 450 474 args)))) 475 451 476 (define plus (if streamed? "*" "")) 477 452 478 (define prefix-plus (if streamed? "stream-" "")) 479 453 480 (define (when-bi . in-args) 454 481 (if bidirectional? in-args '())) 482 455 483 (define (unless-bi . in-args) 456 484 (if bidirectional? '() in-args)) 485 457 486 (let* ((for-each+ (pad prefix-plus "for-each")) 458 487 (map+ (pad prefix-plus "map")) … … 600 629 (let ((v^u (,edge g v u))) 601 630 (when v^u (,remove-edge! g v^u))))) 602 (hash-table- remove! table u))))631 (hash-table-delete! table u)))) 603 632 (define ,vertex-eq? 604 633 (lambda (g u v) … … 635 664 (lambda (g) 636 665 (let* ((vl (,get-vl g)) (table (,vl-table vl))) 666 #;(hash-table-clear! table) 637 667 (##sys#setslot table 1 (make-vector (##sys#size (##sys#slot table 1)) '()))))))))) 668 638 669 (define rgraph-doc-el-slist #t) 670 639 671 (define-macro 640 672 define-el-slist … … 644 676 bidirectional? 645 677 edge-properties) 678 646 679 (define (pad . args) 647 680 (string->symbol … … 652 685 (else "UNKNOWN_PAD_SYMBOL"))) 653 686 args)))) 687 654 688 (define (when-bi . in-args) 655 689 (if bidirectional? in-args '())) 690 656 691 (let* ((NP (length edge-properties)) 657 692 (el (pad GTYPE "-edge-list")) … … 803 838 ,@(when-bi 804 839 `(for-each x (,el-tlist (,in-edge-list g u)))))))))) 840 805 841 (define rgraph-doc-el-hash #t) 842 806 843 (define-macro 807 844 define-el-hash … … 811 848 bidirectional? 812 849 edge-properties) 850 813 851 (define (pad . args) 814 852 (string->symbol … … 819 857 (else "UNKNOWN_PAD_SYMBOL"))) 820 858 args)))) 859 821 860 (define (when-bi . in-args) 822 861 (if bidirectional? in-args '())) 862 823 863 (let* ((NP (length edge-properties)) 824 864 (el (pad GTYPE "-edge-list")) … … 886 926 (lambda (g) 887 927 (make-hash-table 888 (lambda (a b) (,vertex-eq? g a b))))) 928 (lambda (a b) (,vertex-eq? g a b)) 929 hash))) 889 930 (define ,constructor 890 931 (lambda (g) (,make-el (,pre-constructor g)))) … … 917 958 (let* ((u-thash (,el-thash u-el))) 918 959 (unless 919 (hash-table- remove! u-thash v)960 (hash-table-delete! u-thash v) 920 961 (error "Could not remove directed edge" 921 962 g … … 935 976 (lambda (g u u-el out?) 936 977 (hash-table-map 978 (,el-thash u-el) 937 979 (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)))))) 940 981 (define ,edges* 941 982 (lambda (g u u-el out?) … … 960 1001 (hash-table-set! new-thash (proc v) v-rec)) 961 1002 (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))) 964 1005 (,set-el-thash! 965 1006 (,out-edge-list g u) … … 967 1008 ,@(when-bi 968 1009 `(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))) 971 1012 `(,set-el-thash! (,in-edge-list g u) new-in-thash)))))))) 1013 972 1014 (define rgraph-doc-visitors #t) 973 1015 (define rgraph-doc-properties #t) 974 1016 (define rgraph-doc-let-rgraph #t) 1017 975 1018 (define-macro 976 1019 let-rgraph 977 1020 (lambda (GTYPE . rest) 1021 978 1022 (define plus 979 1023 (cond-expand (srfi-40 "*") (else ""))) 1024 980 1025 (define prefix-plus 981 1026 (cond-expand (srfi-40 "stream-") (else ""))) 1027 982 1028 (define (pad . args) 983 1029 (string->symbol … … 988 1034 (else "UNKNOWN_PAD_SYMBOL"))) 989 1035 args)))) 1036 990 1037 (let ((for-each+ (pad prefix-plus "for-each")) 991 1038 (map+ (pad prefix-plus "map")) … … 1045 1092 (edge-at ,edge-at)) 1046 1093 ,@rest)))) 1094 1047 1095 (define rgraph-doc-fill-graph! #t) 1096 1048 1097 (define-macro 1049 1098 (import-fill-graph! … … 1054 1103 directed? 1055 1104 bidirectional?) 1105 1056 1106 (define (pad . args) 1057 1107 (string->symbol … … 1062 1112 (else "UNKNOWN_PAD_SYMBOL"))) 1063 1113 args)))) 1114 1064 1115 (define (when-bi . in-args) 1065 1116 (if bidirectional? in-args '())) 1117 1066 1118 (let ((algorithm (pad GTYPE "-fill-graph!")) 1067 1119 (vertex-eq? (pad GTYPE "-vertex-eq?")) … … 1090 1142 edges) 1091 1143 g)))) 1144 1092 1145 (define rgraph-doc-dfs #t) 1093 (define rgraph-doc-dfs #t) 1146 1094 1147 (define-macro 1095 1148 (import-depth-first-search … … 1100 1153 directed? 1101 1154 bidirectional?) 1155 1102 1156 (define (pad . args) 1103 1157 (string->symbol … … 1108 1162 (else "UNKNOWN_PAD_SYMBOL"))) 1109 1163 args)))) 1164 1110 1165 (define (when-bi . in-args) 1111 1166 (if bidirectional? in-args '())) 1167 1112 1168 `(begin 1113 1169 ,@(map (lambda (streamed?) … … 1187 1243 #f))))))) 1188 1244 (if streamed? (list #f #t) (list #f))))) 1245 1189 1246 (define rgraph-doc-dfv #t) 1247 1190 1248 (define-macro 1191 1249 (import-depth-first-visit … … 1196 1254 directed? 1197 1255 bidirectional?) 1256 1257 (define (pad . args) 1258 (string->symbol 1259 (apply string-append 1260 (map (lambda (a) 1261 (cond ((string? a) a) 1262 ((symbol? a) (symbol->string a)) 1263 (else "UNKNOWN_PAD_SYMBOL"))) 1264 args)))) 1265 1198 1266 `(begin 1199 1267 ,@(map (lambda (streamed?) … … 1204 1272 (depth-first-search+ 1205 1273 (pad GTYPE "-depth-first-search" plus))) 1206 `(define ,algorithm 1274 `(define ,algorithm+ 1207 1275 (lambda (g dfs-visitor color-map u) 1208 1276 (,depth-first-search+ … … 1212 1280 (cons 'depth-first-visit u)))))) 1213 1281 (if streamed? (list #f #t) (list #f))))) 1214 (define rgraph-doc-topsort #t) 1282 1215 1283 (define rgraph-doc-topsort #t) 1216 1284 (define rgraph-doc-topsort* #t) 1285 1217 1286 (define-macro 1218 1287 (import-topological-sort … … 1223 1292 directed? 1224 1293 bidirectional?) 1294 1225 1295 (define (pad . args) 1226 1296 (string->symbol … … 1231 1301 (else "UNKNOWN_PAD_SYMBOL"))) 1232 1302 args)))) 1303 1233 1304 `(begin 1234 1305 ,@(map (lambda (streamed?) … … 1305 1376 `first))))) 1306 1377 (if streamed? (list #f #t) (list #f))))) 1378 1307 1379 (define rgraph-doc-part-fidmat #t) 1308 1380 (define fidmat-check #t) 1309 1381 (define fidmat-debug #t) 1382 1310 1383 (define-record partition-fm cost balance vertex) 1384 1311 1385 (define-macro 1312 1386 (import-partition-fidmat … … 1317 1391 directed? 1318 1392 bidirectional?) 1393 1319 1394 (define (pad . args) 1320 1395 (string->symbol … … 1325 1400 (else "UNKNOWN_PAD_SYMBOL"))) 1326 1401 args)))) 1402 1327 1403 (define (when-bi . in-args) 1328 1404 (if bidirectional? in-args '())) 1405 1329 1406 (define check 1330 1407 (pad GTYPE "-partition-fidmat-check")) 1408 1331 1409 (define debug 1332 1410 (pad GTYPE "-partition-fidmat-debug")) 1411 1333 1412 `(begin 1334 1413 (define ,check #f) … … 1555 1634 (loop1 c)))))))))))) 1556 1635 (if streamed? (list #f #t) (list #f))))) 1636 1557 1637 (define rgraph-doc-partition-fidmat-check #t) 1558 1638 (define rgraph-doc-partition-fidmat-debug #t) -
release/3/rgraph/tags/0.3.4/rgraph.setup
r9978 r10005 1 1 ;;;; rgraph.setup -*- Hen -*- 2 2 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) 4 4 5 5 (install-extension -
release/3/rgraph/trunk/rgraph-base.scm
r9978 r10005 35 35 (cond-expand 36 36 [chicken 37 (require-extension extras srfi-69) ; hash-table 38 39 ] 37 (require-extension srfi-69) ; hash-table 38 (require-extension srfi-40)] 40 39 (else)) 41 40 42 41 (cond-expand 43 [(and chicken (or srfi-40 srfi-41))42 [(and chicken srfi-40) 44 43 (define (hash-table->stream ht) 45 44 (##sys#check-structure ht 'hash-table 'hash-table->stream) … … 50 49 (if (fx>= i len) 51 50 lst 52 (let loop ([bucket (##sys#slot vec i)] [lst lst]) 51 (let loop ([bucket (##sys#slot vec i)] 52 [lst lst]) 53 53 (if (null? bucket) 54 54 (iter (fx+ i 1) lst) … … 59 59 (else)) 60 60 61 #; 61 62 (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 63 73 (define (vector->stream vct) 64 74 (let ([l (vector-length vct)]) … … 114 124 (define vertex-equal? 115 125 (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)) 117 127 (define vertex-name (graph:get graph 'vertex-name)) 118 128 (for-each -
release/3/rgraph/trunk/rgraph-prop.scm
r9977 r10005 62 62 (define (prop-external-hash eq? . num) 63 63 (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)))]) 66 66 (cons 67 67 (lambda (g k) (hash-table-ref store k)) … … 76 76 (define (prop-external-vector . num) 77 77 (let ([store (if (null? num) 78 (make-vector )78 (make-vector 0) 79 79 (make-vector (car num)))]) 80 80 (cons 81 (lambda (g k) (vector-ref store k)) 81 (lambda (g k) 82 (vector-ref store k)) 82 83 (lambda (g k v) 83 84 (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))))))) 85 86 (vector-set! store k v))))) -
release/3/rgraph/trunk/rgraph-test1.scm
r9977 r10005 103 103 (lambda () 104 104 (let* ((pgetters 105 (make-hash-table eq? ,(+ NVP NEP)))105 (make-hash-table eq? hash-by-identity ,(+ NVP NEP))) 106 106 (psetters 107 (make-hash-table eq? ,(+ NVP NEP)))107 (make-hash-table eq? hash-by-identity ,(+ NVP NEP))) 108 108 (rec (,make-rec #f pgetters psetters))) 109 109 (,set-rec-vl! rec (,vl-constructor rec)) … … 685 685 (lambda (g) 686 686 (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))))) 688 688 (define ,vertices* 689 689 (lambda (g) … … 977 977 (lambda (g) 978 978 (make-hash-table 979 (lambda (a b) (,vertex-eq? g a b))))) 979 (lambda (a b) (,vertex-eq? g a b)) 980 hash))) 980 981 (define ,constructor 981 982 (lambda (g) (,make-el (,pre-constructor g)))) … … 1033 1034 (lambda (g u u-el out?) 1034 1035 (hash-table-map 1036 (,el-thash u-el) 1035 1037 (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)))))) 1038 1039 (define ,edges* 1039 1040 (lambda (g u u-el out?) … … 1065 1066 ,@(when-bi 1066 1067 `(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))) 1069 1070 `(,set-el-thash! 1070 1071 (,in-edge-list g u) -
release/3/rgraph/trunk/rgraph-test2.scm
r9977 r10005 34 34 35 35 (require-extension srfi-40) 36 (register-feature! 'srfi-40) 36 37 (cond-expand 37 38 [srfi-40 -
release/3/rgraph/trunk/rgraph-test3.scm
r9977 r10005 34 34 35 35 (require-extension srfi-40) 36 (register-feature! 'srfi-40) 36 37 (cond-expand 37 38 [srfi-40 -
release/3/rgraph/trunk/rgraph.scm
r9978 r10005 5 5 (define rgraph-doc-usage-imports #t) 6 6 (define rgraph-doc-usage-debugging #t) 7 7 8 (cond-expand 8 9 (rgraph-nodebug 10 9 11 (define-macro rgraph-debug (lambda (body) '()))) 12 10 13 ((or rgraph-debug csi) 14 11 15 (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 13 21 (define rgraph-doc-adjacency-list #t) 22 14 23 (define-macro 15 24 define-adjacency-list … … 22 31 directed? 23 32 bidirectional?) 33 24 34 (define (pad . args) 25 35 (string->symbol … … 30 40 (else "UNKNOWN_PAD_SYMBOL"))) 31 41 args)))) 42 32 43 (define (when-bi . in-args) 33 44 (if bidirectional? in-args '())) 45 34 46 (define (when-bi-or-dir . in-args) 35 47 (if (or bidirectional? directed?) in-args '())) 48 36 49 (let* ((NVP (length vertex-properties)) 37 50 (NEP (length edge-properties)) … … 103 116 (define ,constructor 104 117 (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))) 107 120 (rec (,make-rec #f pgetters psetters))) 108 121 (,set-rec-vl! rec (,vl-constructor rec)) … … 199 212 ,bidirectional?)) 200 213 algorithms))))) 214 201 215 (define rgraph-doc-vl-vector #t) 216 202 217 (define-macro 203 218 define-vl-vector … … 208 223 vertex-properties 209 224 get-vl) 225 210 226 (define (pad . args) 211 227 (string->symbol … … 216 232 (else "UNKNOWN_PAD_SYMBOL"))) 217 233 args)))) 234 218 235 (define plus (if streamed? "*" "")) 236 219 237 (define prefix-plus (if streamed? "stream-" "")) 238 220 239 (define (when-bi . in-args) 221 240 (if bidirectional? in-args '())) 241 222 242 (define (unless-bi . in-args) 223 243 (if bidirectional? '() in-args)) 244 224 245 (let* ((for-each+ (pad prefix-plus "for-each")) 225 246 (map+ (pad prefix-plus "map")) … … 432 453 (,set-vl-num! vl 0) 433 454 (,set-vl-vec! vl (make-vector 0))))))))) 455 434 456 (define rgraph-doc-vl-hash #t) 457 435 458 (define-macro 436 459 define-vl-hash … … 441 464 vertex-properties 442 465 get-vl) 466 443 467 (define (pad . args) 444 468 (string->symbol … … 449 473 (else "UNKNOWN_PAD_SYMBOL"))) 450 474 args)))) 475 451 476 (define plus (if streamed? "*" "")) 477 452 478 (define prefix-plus (if streamed? "stream-" "")) 479 453 480 (define (when-bi . in-args) 454 481 (if bidirectional? in-args '())) 482 455 483 (define (unless-bi . in-args) 456 484 (if bidirectional? '() in-args)) 485 457 486 (let* ((for-each+ (pad prefix-plus "for-each")) 458 487 (map+ (pad prefix-plus "map")) … … 600 629 (let ((v^u (,edge g v u))) 601 630 (when v^u (,remove-edge! g v^u))))) 602 (hash-table- remove! table u))))631 (hash-table-delete! table u)))) 603 632 (define ,vertex-eq? 604 633 (lambda (g u v) … … 635 664 (lambda (g) 636 665 (let* ((vl (,get-vl g)) (table (,vl-table vl))) 666 #;(hash-table-clear! table) 637 667 (##sys#setslot table 1 (make-vector (##sys#size (##sys#slot table 1)) '()))))))))) 668 638 669 (define rgraph-doc-el-slist #t) 670 639 671 (define-macro 640 672 define-el-slist … … 644 676 bidirectional? 645 677 edge-properties) 678 646 679 (define (pad . args) 647 680 (string->symbol … … 652 685 (else "UNKNOWN_PAD_SYMBOL"))) 653 686 args)))) 687 654 688 (define (when-bi . in-args) 655 689 (if bidirectional? in-args '())) 690 656 691 (let* ((NP (length edge-properties)) 657 692 (el (pad GTYPE "-edge-list")) … … 803 838 ,@(when-bi 804 839 `(for-each x (,el-tlist (,in-edge-list g u)))))))))) 840 805 841 (define rgraph-doc-el-hash #t) 842 806 843 (define-macro 807 844 define-el-hash … … 811 848 bidirectional? 812 849 edge-properties) 850 813 851 (define (pad . args) 814 852 (string->symbol … … 819 857 (else "UNKNOWN_PAD_SYMBOL"))) 820 858 args)))) 859 821 860 (define (when-bi . in-args) 822 861 (if bidirectional? in-args '())) 862 823 863 (let* ((NP (length edge-properties)) 824 864 (el (pad GTYPE "-edge-list")) … … 886 926 (lambda (g) 887 927 (make-hash-table 888 (lambda (a b) (,vertex-eq? g a b))))) 928 (lambda (a b) (,vertex-eq? g a b)) 929 hash))) 889 930 (define ,constructor 890 931 (lambda (g) (,make-el (,pre-constructor g)))) … … 917 958 (let* ((u-thash (,el-thash u-el))) 918 959 (unless 919 (hash-table- remove! u-thash v)960 (hash-table-delete! u-thash v) 920 961 (error "Could not remove directed edge" 921 962 g … … 935 976 (lambda (g u u-el out?) 936 977 (hash-table-map 978 (,el-thash u-el) 937 979 (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)))))) 940 981 (define ,edges* 941 982 (lambda (g u u-el out?) … … 960 1001 (hash-table-set! new-thash (proc v) v-rec)) 961 1002 (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))) 964 1005 (,set-el-thash! 965 1006 (,out-edge-list g u) … … 967 1008 ,@(when-bi 968 1009 `(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))) 971 1012 `(,set-el-thash! (,in-edge-list g u) new-in-thash)))))))) 1013 972 1014 (define rgraph-doc-visitors #t) 973 1015 (define rgraph-doc-properties #t) 974 1016 (define rgraph-doc-let-rgraph #t) 1017 975 1018 (define-macro 976 1019 let-rgraph 977 1020 (lambda (GTYPE . rest) 1021 978 1022 (define plus 979 1023 (cond-expand (srfi-40 "*") (else ""))) 1024 980 1025 (define prefix-plus 981 1026 (cond-expand (srfi-40 "stream-") (else ""))) 1027 982 1028 (define (pad . args) 983 1029 (string->symbol … … 988 1034 (else "UNKNOWN_PAD_SYMBOL"))) 989 1035 args)))) 1036 990 1037 (let ((for-each+ (pad prefix-plus "for-each")) 991 1038 (map+ (pad prefix-plus "map")) … … 1045 1092 (edge-at ,edge-at)) 1046 1093 ,@rest)))) 1094 1047 1095 (define rgraph-doc-fill-graph! #t) 1096 1048 1097 (define-macro 1049 1098 (import-fill-graph! … … 1054 1103 directed? 1055 1104 bidirectional?) 1105 1056 1106 (define (pad . args) 1057 1107 (string->symbol … … 1062 1112 (else "UNKNOWN_PAD_SYMBOL"))) 1063 1113 args)))) 1114 1064 1115 (define (when-bi . in-args) 1065 1116 (if bidirectional? in-args '())) 1117 1066 1118 (let ((algorithm (pad GTYPE "-fill-graph!")) 1067 1119 (vertex-eq? (pad GTYPE "-vertex-eq?")) … … 1090 1142 edges) 1091 1143 g)))) 1144 1092 1145 (define rgraph-doc-dfs #t) 1093 (define rgraph-doc-dfs #t) 1146 1094 1147 (define-macro 1095 1148 (import-depth-first-search … … 1100 1153 directed? 1101 1154 bidirectional?) 1155 1102 1156 (define (pad . args) 1103 1157 (string->symbol … … 1108 1162 (else "UNKNOWN_PAD_SYMBOL"))) 1109 1163 args)))) 1164 1110 1165 (define (when-bi . in-args) 1111 1166 (if bidirectional? in-args '())) 1167 1112 1168 `(begin 1113 1169 ,@(map (lambda (streamed?) … … 1187 1243 #f))))))) 1188 1244 (if streamed? (list #f #t) (list #f))))) 1245 1189 1246 (define rgraph-doc-dfv #t) 1247 1190 1248 (define-macro 1191 1249 (import-depth-first-visit … … 1196 1254 directed? 1197 1255 bidirectional?) 1256 1257 (define (pad . args) 1258 (string->symbol 1259 (apply string-append 1260 (map (lambda (a) 1261 (cond ((string? a) a) 1262 ((symbol? a) (symbol->string a)) 1263 (else "UNKNOWN_PAD_SYMBOL"))) 1264 args)))) 1265 1198 1266 `(begin 1199 1267 ,@(map (lambda (streamed?) … … 1204 1272 (depth-first-search+ 1205 1273 (pad GTYPE "-depth-first-search" plus))) 1206 `(define ,algorithm 1274 `(define ,algorithm+ 1207 1275 (lambda (g dfs-visitor color-map u) 1208 1276 (,depth-first-search+ … … 1212 1280 (cons 'depth-first-visit u)))))) 1213 1281 (if streamed? (list #f #t) (list #f))))) 1214 (define rgraph-doc-topsort #t) 1282 1215 1283 (define rgraph-doc-topsort #t) 1216 1284 (define rgraph-doc-topsort* #t) 1285 1217 1286 (define-macro 1218 1287 (import-topological-sort … … 1223 1292 directed? 1224 1293 bidirectional?) 1294 1225 1295 (define (pad . args) 1226 1296 (string->symbol … … 1231 1301 (else "UNKNOWN_PAD_SYMBOL"))) 1232 1302 args)))) 1303 1233 1304 `(begin 1234 1305 ,@(map (lambda (streamed?) … … 1305 1376 `first))))) 1306 1377 (if streamed? (list #f #t) (list #f))))) 1378 1307 1379 (define rgraph-doc-part-fidmat #t) 1308 1380 (define fidmat-check #t) 1309 1381 (define fidmat-debug #t) 1382 1310 1383 (define-record partition-fm cost balance vertex) 1384 1311 1385 (define-macro 1312 1386 (import-partition-fidmat … … 1317 1391 directed? 1318 1392 bidirectional?) 1393 1319 1394 (define (pad . args) 1320 1395 (string->symbol … … 1325 1400 (else "UNKNOWN_PAD_SYMBOL"))) 1326 1401 args)))) 1402 1327 1403 (define (when-bi . in-args) 1328 1404 (if bidirectional? in-args '())) 1405 1329 1406 (define check 1330 1407 (pad GTYPE "-partition-fidmat-check")) 1408 1331 1409 (define debug 1332 1410 (pad GTYPE "-partition-fidmat-debug")) 1411 1333 1412 `(begin 1334 1413 (define ,check #f) … … 1555 1634 (loop1 c)))))))))))) 1556 1635 (if streamed? (list #f #t) (list #f))))) 1636 1557 1637 (define rgraph-doc-partition-fidmat-check #t) 1558 1638 (define rgraph-doc-partition-fidmat-debug #t) -
release/3/rgraph/trunk/rgraph.setup
r9978 r10005 1 1 ;;;; rgraph.setup -*- Hen -*- 2 2 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) 4 4 5 5 (install-extension
Note: See TracChangeset
for help on using the changeset viewer.