source: project/release/3/rgraph/trunk/rgraph-test3.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: 5.7 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;(load "rgraph")
47;(load "rgraph-base")
48
49
50;; Adapted from
51;; http://www.boost.org/libs/graph/doc/file_dependency_example.html
52;; using Scheme style.
53(define used-by
54  (list
55    (cons 'dax_h 'foo_cpp) (cons 'dax_h 'bar_cpp) (cons 'dax_h 'yow_h)
56    (cons 'yow_h 'bar_cpp) (cons 'yow_h 'zag_cpp)
57    (cons 'boz_h 'bar_cpp) (cons 'boz_h 'zig_cpp) (cons 'boz_h 'zag_cpp)
58    (cons 'zow_h 'foo_cpp) 
59    (cons 'foo_cpp 'foo_o) 
60    (cons 'foo_o 'libfoobar_a) 
61    (cons 'bar_cpp 'bar_o) 
62    (cons 'bar_o 'libfoobar_a) 
63    (cons 'libfoobar_a 'libzigzag_a) 
64    (cons 'zig_cpp 'zig_o) 
65    (cons 'zig_o 'libzigzag_a) 
66    (cons 'zag_cpp 'zag_o) 
67    (cons 'zag_o 'libzigzag_a) 
68    (cons 'libzigzag_a 'killerapp)))
69
70(define-adjacency-list myg1
71  (fill-graph! 
72   depth-first-search
73   topological-sort 
74   partition-fidmat
75   )
76  (vl-vector) (vertex-name vertex-color)
77  (el-hash) (edge-weight)
78  #t #t)
79
80(define g1 (make-myg1))
81(myg1-fill-graph! g1 used-by set-myg1-vertex-name!)
82
83(print "Vertex order [list]:")
84(for-each
85 (lambda (v) (print (myg1-vertex-name g1 v)))
86 (myg1-vertices g1))
87
88(print "Vertex order [stream]:")
89(stream-for-each
90 (lambda (v) (print (myg1-vertex-name g1 v)))
91 (myg1-vertices* g1))
92
93;; topo sort
94(print "Topological sort [list]:")
95(for-each
96 (lambda (v) 
97   (print (myg1-vertex-name g1 v)))
98  (myg1-topological-sort g1))
99
100(print "Topological sort [stream]:")
101(stream-for-each
102 (lambda (v) 
103   (print (myg1-vertex-name g1 v)))
104  (myg1-topological-sort* g1))
105
106(print "Partition Fiduccia-Mattheyses:")
107(let dummy ()
108  (define g g1)
109  (define partition-map 
110    (prop-external-hash (lambda (v1 v2) (myg1-vertex-eq? g v1 v2))))
111  (define partition (car partition-map))
112  (define set-partition! (cdr partition-map))
113  (define gain
114    (lambda (g u)
115      (let* ([u-nbs (myg1-neighbours g1 u)]
116             [total (length u-nbs)]
117             [p1 (partition g u)]
118             ;; what is edge cost now?
119             [now (rgraph-count
120                   (lambda (u-nb) (not (eq? p1 (partition g (car u-nb)))))
121                   u-nbs)]
122             ;; what is edge cost later, when moved?
123             [later (- total now)])
124        ;; if cell is moved and causes increase in solution cost
125        ;; (that is, later > now), then the gain is negative
126        (- now later))))
127  (define (cost)
128    (let ([t 0])
129      ;; count all edges from one partition to another (the edge
130      ;; cut). note that this will double count if undirected edges,
131      ;; since both edges A->B and B->A will be counted.
132      (for-each
133       (lambda (u)
134         (let ([p1 (partition g u)])
135           (set! t
136                 (+ t (rgraph-count
137                       (lambda (u-nb) (not (eq? p1 (partition g (car u-nb)))))
138                       (myg1-neighbours g u))))))
139       (myg1-vertices g))
140      (quotient t 2)))
141  (define (balance weight n#f n#t)
142    (let ([b 0])
143      (cond
144       [(and n#f n#t)
145        (set! b (- (* (car weight) n#t) (* (cdr weight) n#f)))]
146       [else
147        (set! n#t 0)
148        (set! n#f 0)
149        (for-each
150         (lambda (c)
151           (set! n#t (add1 n#t))
152           (set! b
153                 (+ b
154                    (if (partition g c)
155                        (car weight)
156                        (- (cdr weight))))))
157         (myg1-vertices g))])
158      (quotient (* (abs b) 100) 
159                (* (max (car weight) (cdr weight))
160                   (+ n#t n#f)))))
161  (define working-graph (make-myg1))
162  ;; we could use prop-external-vector, but would only work if graph's
163  ;; vertex list was vl-vector
164  (define working-prop-map (prop-external-hash eq? (myg1-num-vertices g)))
165  (define (output part)
166    (map
167     (lambda (u)
168       (if (eq? (partition g u) part)
169           (myg1-vertex-name g u)
170           '-))
171     (myg1-vertices g)))
172 
173  (set! myg1-partition-fidmat-check #t)
174  (set! myg1-partition-fidmat-debug #t)
175  (myg1-partition-fidmat
176   g partition-map gain (prop-external-hash eq? (myg1-num-vertices g))
177   working-graph (prop-external-hash eq? (myg1-num-vertices g))
178   cost balance '(1 . 1) 25 3)
179  (set! working-graph #f)
180 
181  (print "Partition #f")
182  (print "  " (output #f))
183  (newline)
184  (print "Partition #t")
185  (print "  " (output #t))
186  (newline)
187  (print "Balance " (balance '(1 . 1) #f #f)))
188
189(void)
Note: See TracBrowser for help on using the repository browser.