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