1 ; This benchmark was obtained from Andrew Wright.
2 ; 970215 / wdc Added lattice-benchmark.
4 ; Given a comparison routine that returns one of
9 ; return a new comparison routine that applies to sequences.
13 (lambda (fixed lhs rhs)
21 (if (or (eq? probe 'equal)
46 (define (make-lattice elem-list cmp-func)
47 (cons elem-list cmp-func))
49 (define lattice->elements car)
51 (define lattice->cmp cdr)
53 ; Select elements of a list which pass some test.
61 (let ((head (car lst)))
71 (let ((next (cdr fo)))
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.
85 (lambda (test func lst)
91 (let ((head (car lst)))
101 ; This version of map-and tail-recurses on the last test.
108 (let ((rest (cdr lst)))
111 (and (proc (car lst))
115 (define (maps-1 source target pas new)
116 (let ((scmp (lattice->cmp source))
117 (tcmp (lattice->cmp target)))
137 (memq (tcmp t2 t) '(less equal)))
141 (memq (tcmp t2 t) '(more equal)))
143 (lattice->elements target)))))
145 (define (maps-rest source target pas rest to-1 to-collect)
148 (let ((next (car rest))
153 (maps-rest source target
160 (maps-1 source target pas next))))))
162 (define (maps source target)
167 (lattice->elements source)
168 (lambda (x) (list (map cdr x)))
169 (lambda (x) (apply append x)))
170 (lexico (lattice->cmp target))))
172 (define print-frequency 10000)
174 (define (count-maps source target)
179 (lattice->elements source)
181 (set! count (+ count 1))
182 (if (= 0 (remainder count print-frequency))
185 (lambda (x) (apply + x)))))
187 (define (lattice-benchmark)
188 (run-benchmark "Lattice"
191 (make-lattice '(low high)
201 (error 'make-lattice "base" rhs))))
209 (error 'make-lattice "base" rhs))))
211 (error 'make-lattice "base" lhs))))))
218 (count-maps l4 l4)))))