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