1 | ; Copyright (c) 2004, Jonah Nathaniel Beckford |
---|
2 | ; All rights reserved. |
---|
3 | ; |
---|
4 | ; Redistribution and use in source and binary forms, with or without |
---|
5 | ; modification, are permitted provided that the following conditions |
---|
6 | ; are met: |
---|
7 | ; |
---|
8 | ; Redistributions of source code must retain the above copyright |
---|
9 | ; notice, this list of conditions and the following disclaimer. |
---|
10 | ; |
---|
11 | ; Redistributions in binary form must reproduce the above copyright |
---|
12 | ; notice, this list of conditions and the following disclaimer in |
---|
13 | ; the documentation and/or other materials provided with the |
---|
14 | ; distribution. |
---|
15 | ; |
---|
16 | ; Neither the name of the author nor the names of its contributors |
---|
17 | ; may be used to endorse or promote products derived from this |
---|
18 | ; software without specific prior written permission. |
---|
19 | ; |
---|
20 | ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
---|
21 | ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
---|
22 | ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS |
---|
23 | ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE |
---|
24 | ; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, |
---|
25 | ; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES |
---|
26 | ; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
---|
27 | ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) |
---|
28 | ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, |
---|
29 | ; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) |
---|
30 | ; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED |
---|
31 | ; OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
32 | ; |
---|
33 | ; jonah@usermail.com |
---|
34 | |
---|
35 | (require-extension srfi-40) |
---|
36 | (cond-expand |
---|
37 | [srfi-40 |
---|
38 | (print "Using rgraph stream functions; found 'srfi-40 extension")] |
---|
39 | [else |
---|
40 | (print "Not using rgraph stream functions because no 'srfi-40 extension")]) |
---|
41 | (newline) |
---|
42 | |
---|
43 | (require-for-syntax 'rgraph) |
---|
44 | (require 'rgraph-base) |
---|
45 | |
---|
46 | |
---|
47 | (print "define-adjacency-list ...") |
---|
48 | (define-adjacency-list myg1 |
---|
49 | () |
---|
50 | (vl-hash) (vertex-name vertex-color) |
---|
51 | (el-hash) (edge-weight) |
---|
52 | #t #t) |
---|
53 | (newline) |
---|
54 | |
---|
55 | |
---|
56 | (print "make ...") |
---|
57 | (define g1 (make-myg1)) |
---|
58 | (print g1) |
---|
59 | (newline) |
---|
60 | |
---|
61 | |
---|
62 | (print "add-vertex! add-edge! ...") |
---|
63 | (define v1 (myg1-add-vertex! g1 'v1)) |
---|
64 | (define v2 (myg1-add-vertex! g1 'v2)) |
---|
65 | (define v3 (myg1-add-vertex! g1 'v3)) |
---|
66 | (define e1 (myg1-add-edge! g1 v1 v2)) |
---|
67 | (define e2 (myg1-add-edge! g1 v1 v3)) |
---|
68 | (define e3 (myg1-add-edge! g1 v2 v3)) |
---|
69 | (print e1) |
---|
70 | (newline) |
---|
71 | |
---|
72 | |
---|
73 | (print "vertices ...") |
---|
74 | (print (myg1-vertices g1)) |
---|
75 | (cond-expand |
---|
76 | [srfi-40 |
---|
77 | (stream-for-each print (myg1-vertices* g1))] |
---|
78 | [else]) |
---|
79 | |
---|
80 | |
---|
81 | (print "edge ...") |
---|
82 | (let-rgraph myg1 |
---|
83 | (print (edge g1 v1 v2)) |
---|
84 | (newline)) |
---|
85 | |
---|
86 | |
---|
87 | (print "out-edges ...") |
---|
88 | (print (myg1-out-edges g1 v2)) |
---|
89 | (cond-expand |
---|
90 | [srfi-40 |
---|
91 | (stream-for-each print (myg1-out-edges* g1 v1))] |
---|
92 | [else |
---|
93 | (print (myg1-out-edges g1 v1))]) |
---|
94 | (newline) |
---|
95 | |
---|
96 | (print "in-edges ...") |
---|
97 | (print (myg1-in-edges g1 v2)) |
---|
98 | (cond-expand |
---|
99 | [srfi-40 |
---|
100 | (stream-for-each print (myg1-in-edges* g1 v3))] |
---|
101 | [else |
---|
102 | (print (myg1-in-edges g1 v3))]) |
---|
103 | (newline) |
---|
104 | |
---|
105 | |
---|
106 | (print "internal properties ...") |
---|
107 | (set-myg1-vertex-name! g1 v1 "first vertex name") |
---|
108 | (print (myg1-vertex-name g1 v1)) |
---|
109 | (print (myg1-vertex-name g1 v2)) |
---|
110 | (set-myg1-edge-weight! g1 e1 "first edge weight") |
---|
111 | (print (myg1-edge-weight g1 e1)) |
---|
112 | (print (myg1-edge-weight g1 e2)) |
---|
113 | (newline) |
---|
114 | |
---|
115 | |
---|
116 | (print "num-vertices / num-edges ...") |
---|
117 | ;; when remove a vertex, all edges it belongs too must be deleted as |
---|
118 | ;; well. so number of edges should decrement by one for this example. |
---|
119 | (define t1 (myg1-num-vertices g1)) |
---|
120 | (define t2 (myg1-out-degree g1 v1)) |
---|
121 | (define s2 (myg1-in-degree g1 v3)) |
---|
122 | (printf "out ~S / ~S~%" t1 t2) |
---|
123 | (printf "in ~S / ~S~%" t1 s2) |
---|
124 | (myg1-remove-vertex! g1 v2) |
---|
125 | (when (and (integer? v3) (not (myg1-vertex-set?))) |
---|
126 | ;; this should work, because the old vertex 3 is now vertex 2. |
---|
127 | ;; ONLY for vl-vector |
---|
128 | (set! v3 (myg1-vertex g1 1))) |
---|
129 | (define t3 (myg1-num-vertices g1)) |
---|
130 | (define t4 (myg1-out-degree g1 v1)) |
---|
131 | (define s4 (myg1-in-degree g1 v3)) |
---|
132 | (unless (= (sub1 t1) t3) |
---|
133 | (error "The number of vertices did not decrease by one")) |
---|
134 | (unless (= (sub1 t2) t4 (length (myg1-out-edges g1 v1))) |
---|
135 | (error "The number of out-edges did not decrease by one")) |
---|
136 | (unless (= (sub1 s2) s4 (length (myg1-in-edges g1 v3))) |
---|
137 | (error "The number of in-edges did not decrease by one")) |
---|
138 | (printf "out ~S / ~S~%" t3 t4) |
---|
139 | (printf "in ~S / ~S~%" t3 s4) |
---|
140 | (cond-expand |
---|
141 | [srfi-40 |
---|
142 | (stream-for-each print (myg1-out-edges* g1 v1))] |
---|
143 | [else |
---|
144 | (print (myg1-out-edges g1 v1))]) |
---|
145 | (unless (myg1-edge g1 v1 v3) |
---|
146 | (error "The vertex descriptor in the edges were not recalculated upon removal of a vertex")) |
---|
147 | (newline) |
---|