| 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 | |