Commit | Line | Data |
---|---|---|
1b706edf LC |
1 | ; This benchmark was obtained from Andrew Wright. |
2 | ; 970215 / wdc Added lattice-benchmark. | |
3 | ||
4 | ; Given a comparison routine that returns one of | |
5 | ; less | |
6 | ; more | |
7 | ; equal | |
8 | ; uncomparable | |
9 | ; return a new comparison routine that applies to sequences. | |
10 | (define lexico | |
11 | (lambda (base) | |
12 | (define lex-fixed | |
13 | (lambda (fixed lhs rhs) | |
14 | (define check | |
15 | (lambda (lhs rhs) | |
16 | (if (null? lhs) | |
17 | fixed | |
18 | (let ((probe | |
19 | (base (car lhs) | |
20 | (car rhs)))) | |
21 | (if (or (eq? probe 'equal) | |
22 | (eq? probe fixed)) | |
23 | (check (cdr lhs) | |
24 | (cdr rhs)) | |
25 | 'uncomparable))))) | |
26 | (check lhs rhs))) | |
27 | (define lex-first | |
28 | (lambda (lhs rhs) | |
29 | (if (null? lhs) | |
30 | 'equal | |
31 | (let ((probe | |
32 | (base (car lhs) | |
33 | (car rhs)))) | |
34 | (case probe | |
35 | ((less more) | |
36 | (lex-fixed probe | |
37 | (cdr lhs) | |
38 | (cdr rhs))) | |
39 | ((equal) | |
40 | (lex-first (cdr lhs) | |
41 | (cdr rhs))) | |
42 | ((uncomparable) | |
43 | 'uncomparable)))))) | |
44 | lex-first)) | |
45 | ||
46 | (define (make-lattice elem-list cmp-func) | |
47 | (cons elem-list cmp-func)) | |
48 | ||
49 | (define lattice->elements car) | |
50 | ||
51 | (define lattice->cmp cdr) | |
52 | ||
53 | ; Select elements of a list which pass some test. | |
54 | (define zulu-select | |
55 | (lambda (test lst) | |
56 | (define select-a | |
57 | (lambda (ac lst) | |
58 | (if (null? lst) | |
59 | (reverse! ac) | |
60 | (select-a | |
61 | (let ((head (car lst))) | |
62 | (if (test head) | |
63 | (cons head ac) | |
64 | ac)) | |
65 | (cdr lst))))) | |
66 | (select-a '() lst))) | |
67 | ||
68 | (define reverse! | |
69 | (letrec ((rotate | |
70 | (lambda (fo fum) | |
71 | (let ((next (cdr fo))) | |
72 | (set-cdr! fo fum) | |
73 | (if (null? next) | |
74 | fo | |
75 | (rotate next fo)))))) | |
76 | (lambda (lst) | |
77 | (if (null? lst) | |
78 | '() | |
79 | (rotate lst '()))))) | |
80 | ||
81 | ; Select elements of a list which pass some test and map a function | |
82 | ; over the result. Note, only efficiency prevents this from being the | |
83 | ; composition of select and map. | |
84 | (define select-map | |
85 | (lambda (test func lst) | |
86 | (define select-a | |
87 | (lambda (ac lst) | |
88 | (if (null? lst) | |
89 | (reverse! ac) | |
90 | (select-a | |
91 | (let ((head (car lst))) | |
92 | (if (test head) | |
93 | (cons (func head) | |
94 | ac) | |
95 | ac)) | |
96 | (cdr lst))))) | |
97 | (select-a '() lst))) | |
98 | ||
99 | ||
100 | ||
101 | ; This version of map-and tail-recurses on the last test. | |
102 | (define map-and | |
103 | (lambda (proc lst) | |
104 | (if (null? lst) | |
105 | #T | |
106 | (letrec ((drudge | |
107 | (lambda (lst) | |
108 | (let ((rest (cdr lst))) | |
109 | (if (null? rest) | |
110 | (proc (car lst)) | |
111 | (and (proc (car lst)) | |
112 | (drudge rest))))))) | |
113 | (drudge lst))))) | |
114 | ||
115 | (define (maps-1 source target pas new) | |
116 | (let ((scmp (lattice->cmp source)) | |
117 | (tcmp (lattice->cmp target))) | |
118 | (let ((less | |
119 | (select-map | |
120 | (lambda (p) | |
121 | (eq? 'less | |
122 | (scmp (car p) new))) | |
123 | cdr | |
124 | pas)) | |
125 | (more | |
126 | (select-map | |
127 | (lambda (p) | |
128 | (eq? 'more | |
129 | (scmp (car p) new))) | |
130 | cdr | |
131 | pas))) | |
132 | (zulu-select | |
133 | (lambda (t) | |
134 | (and | |
135 | (map-and | |
136 | (lambda (t2) | |
137 | (memq (tcmp t2 t) '(less equal))) | |
138 | less) | |
139 | (map-and | |
140 | (lambda (t2) | |
141 | (memq (tcmp t2 t) '(more equal))) | |
142 | more))) | |
143 | (lattice->elements target))))) | |
144 | ||
145 | (define (maps-rest source target pas rest to-1 to-collect) | |
146 | (if (null? rest) | |
147 | (to-1 pas) | |
148 | (let ((next (car rest)) | |
149 | (rest (cdr rest))) | |
150 | (to-collect | |
151 | (map | |
152 | (lambda (x) | |
153 | (maps-rest source target | |
154 | (cons | |
155 | (cons next x) | |
156 | pas) | |
157 | rest | |
158 | to-1 | |
159 | to-collect)) | |
160 | (maps-1 source target pas next)))))) | |
161 | ||
162 | (define (maps source target) | |
163 | (make-lattice | |
164 | (maps-rest source | |
165 | target | |
166 | '() | |
167 | (lattice->elements source) | |
168 | (lambda (x) (list (map cdr x))) | |
169 | (lambda (x) (apply append x))) | |
170 | (lexico (lattice->cmp target)))) | |
171 | ||
172 | (define print-frequency 10000) | |
173 | ||
174 | (define (count-maps source target) | |
175 | (let ((count 0)) | |
176 | (maps-rest source | |
177 | target | |
178 | '() | |
179 | (lattice->elements source) | |
180 | (lambda (x) | |
181 | (set! count (+ count 1)) | |
182 | (if (= 0 (remainder count print-frequency)) | |
183 | (begin #f)) | |
184 | 1) | |
185 | (lambda (x) (apply + x))))) | |
186 | ||
187 | (define (lattice-benchmark) | |
188 | (run-benchmark "Lattice" | |
189 | (lambda () | |
190 | (let* ((l2 | |
191 | (make-lattice '(low high) | |
192 | (lambda (lhs rhs) | |
193 | (case lhs | |
194 | ((low) | |
195 | (case rhs | |
196 | ((low) | |
197 | 'equal) | |
198 | ((high) | |
199 | 'less) | |
200 | (else | |
201 | (error 'make-lattice "base" rhs)))) | |
202 | ((high) | |
203 | (case rhs | |
204 | ((low) | |
205 | 'more) | |
206 | ((high) | |
207 | 'equal) | |
208 | (else | |
209 | (error 'make-lattice "base" rhs)))) | |
210 | (else | |
211 | (error 'make-lattice "base" lhs)))))) | |
212 | (l3 (maps l2 l2)) | |
213 | (l4 (maps l3 l3))) | |
214 | (count-maps l2 l2) | |
215 | (count-maps l3 l3) | |
216 | (count-maps l2 l3) | |
217 | (count-maps l3 l2) | |
218 | (count-maps l4 l4))))) | |
219 |