source: project/release/3/rgraph/trunk/rgraph-test2.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: 4.4 KB
Line 
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(register-feature! 'srfi-40)
37(cond-expand
38  [srfi-40
39    (print "Using rgraph stream functions; found 'srfi-40 extension")]
40  [else
41    (print "Not using rgraph stream functions because no 'srfi-40 extension")])
42(newline)
43
44(require-for-syntax 'rgraph)
45(require 'rgraph-base)
46
47
48(print "define-adjacency-list ...")
49(define-adjacency-list myg1
50  ()
51  (vl-hash) (vertex-name vertex-color)
52  (el-hash) (edge-weight)
53  #t #t)
54(newline)
55
56
57(print "make ...")
58(define g1 (make-myg1))
59(print g1)
60(newline)
61
62
63(print "add-vertex! add-edge! ...")
64(define v1 (myg1-add-vertex! g1 'v1))
65(define v2 (myg1-add-vertex! g1 'v2))
66(define v3 (myg1-add-vertex! g1 'v3))
67(define e1 (myg1-add-edge! g1 v1 v2))
68(define e2 (myg1-add-edge! g1 v1 v3))
69(define e3 (myg1-add-edge! g1 v2 v3))
70(print e1)
71(newline)
72
73
74(print "vertices ...")
75(print (myg1-vertices g1))
76(cond-expand
77  [srfi-40
78    (stream-for-each print (myg1-vertices* g1))]
79  [else])
80
81
82(print "edge ...")
83(let-rgraph myg1
84  (print (edge g1 v1 v2))
85  (newline))
86
87
88(print "out-edges ...")
89(print (myg1-out-edges g1 v2))
90(cond-expand
91  [srfi-40
92    (stream-for-each print (myg1-out-edges* g1 v1))]
93  [else
94    (print (myg1-out-edges g1 v1))])
95(newline)
96
97(print "in-edges ...")
98(print (myg1-in-edges g1 v2))
99(cond-expand
100  [srfi-40
101    (stream-for-each print (myg1-in-edges* g1 v3))]
102  [else
103    (print (myg1-in-edges g1 v3))])
104(newline)
105
106
107(print "internal properties ...")
108(set-myg1-vertex-name! g1 v1 "first vertex name")
109(print (myg1-vertex-name g1 v1))
110(print (myg1-vertex-name g1 v2))
111(set-myg1-edge-weight! g1 e1 "first edge weight")
112(print (myg1-edge-weight g1 e1))
113(print (myg1-edge-weight g1 e2))
114(newline)
115
116
117(print "num-vertices / num-edges ...")
118;; when remove a vertex, all edges it belongs too must be deleted as
119;; well.  so number of edges should decrement by one for this example.
120(define t1 (myg1-num-vertices g1))
121(define t2 (myg1-out-degree g1 v1))
122(define s2 (myg1-in-degree g1 v3))
123(printf "out ~S / ~S~%" t1 t2)
124(printf "in  ~S / ~S~%" t1 s2)
125(myg1-remove-vertex! g1 v2)
126(when (and (integer? v3) (not (myg1-vertex-set?)))
127  ;; this should work, because the old vertex 3 is now vertex 2.
128  ;; ONLY for vl-vector
129  (set! v3 (myg1-vertex g1 1)))
130(define t3 (myg1-num-vertices g1))
131(define t4 (myg1-out-degree g1 v1))
132(define s4 (myg1-in-degree g1 v3))
133(unless (= (sub1 t1) t3)
134  (error "The number of vertices did not decrease by one"))
135(unless (= (sub1 t2) t4 (length (myg1-out-edges g1 v1)))
136  (error "The number of out-edges did not decrease by one"))
137(unless (= (sub1 s2) s4 (length (myg1-in-edges g1 v3)))
138  (error "The number of in-edges did not decrease by one"))
139(printf "out ~S / ~S~%" t3 t4)
140(printf "in  ~S / ~S~%" t3 s4)
141(cond-expand
142  [srfi-40
143    (stream-for-each print (myg1-out-edges* g1 v1))]
144  [else
145    (print (myg1-out-edges g1 v1))])
146(unless (myg1-edge g1 v1 v3)
147  (error "The vertex descriptor in the edges were not recalculated upon removal of a vertex"))
148(newline)
Note: See TracBrowser for help on using the repository browser.