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