source: project/release/3/rgraph/trunk/rgraph-test3.scm @ 9977

Last change on this file since 9977 was 9977, checked in by Kon Lovett, 12 years ago

Using canonical directory structure.

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(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)
Note: See TracBrowser for help on using the repository browser.