1  ; exercise chapter 6
  2  ; little lisper
  3  ; august 13 2005
  4
  5  ;=============================================================================
  6  ; constants
  7  ;=============================================================================
  8  (defconstant l1 (list (list 'fried 'potatoes) (list 'baked (list 'fried)) 'tomatoes))
  9  (defconstant l2 (list (list (list 'chili) 'chili (list 'chili))))
 10  (defconstant l3 ())
 11  (defconstant lat1 (list 'chili 'and 'hot))
 12  (defconstant lat2 (list 'baked 'fried))
 13  (defconstant a 'fried)
 14
 15  ;=============================================================================
 16  ; down*
 17  ;=============================================================================
 18  (defun down* (lat)
 19    (cond
 20     ((null lat) (quote()))
 21     ((consp (car lat)) (cons (down* (car lat)) (down* (cdr lat))))
 22     (t (cons (cons (car lat) (quote())) (down* (cdr lat)))) ;must be atoms
 23    )
 24  )
 25
 26  (down* l2)
 27  (down* l3)
 28  (down* lat1)
 29
 30
 31  ;=============================================================================
 32  ; equal?
 33  ;=============================================================================
 34  (defun equal? (s1 s2)
 35    (cond
 36     ((and (atomp s1) (atomp s2))
 37      (eqan? s1 s2))
 38     ((and (consp s1) (consp s2))
 39      (eqlist? s1 s2))
 40     (t nil)
 41    )
 42  )
 43
 44
 45  ;=============================================================================
 46  ; eqlist?
 47  ;=============================================================================
 48  (defun eqlist? (l1 l2)
 49    (cond
 50     ((and (null l1) (null l2)) t)
 51     ((or (null l1) (null l2)) nil)
 52     (t (and (equal? (car l1) (car l2))
 53             (eqlist? (cdr l1) (cdr l2))))
 54    )
 55  )
 56
 57  ;=============================================================================
 58  ; occurN*
 59  ;=============================================================================
 60
 61
 62    ;===========================================================================
 63    ; helper* function
 64    ;===========================================================================
 65    (defun occurN*_helper* (element lst)
 66      (cond
 67       ((null lst) 0)
 68       ((consp (car lst)) (+ (occurN*_helper* element (car lst)) (occurN*_helper* element (cdr lst))))
 69       ((eq element (car lst)) (+ 1 (occurN*_helper* element (cdr lst))))
 70       (t (+ 0 (occurN*_helper* element (cdr lst))))
 71      )
 72    )
 73
 74  (defun occurN* (alat blat)
 75    (cond
 76     ((null alat) 0)
 77     (t (+ (occurN*_helper* (car alat) blat) (occurN* (cdr alat) blat)))
 78    )
 79  )
 80
 81  (occurN* lat1 l2)
 82  (occurN* lat2 l1)
 83  (occurN* lat1 l3)
 84
 85
 86  ;=============================================================================
 87  ; double*
 88  ;=============================================================================
 89  (defun double* (element l)
 90    (cond
 91     ((null l) (quote()))
 92     ((consp (car l)) (cons (double* element (car l)) (double* element (cdr l))))
 93     ((eq element (car l)) (cons element (cons element (double* element (cdr l)))))
 94     (t (cons (car l) (double* element (cdr l))))
 95    )
 96  )
 97
 98  (double* a l1)
 99  (double* a l2)
100  (double* a lat2)
101
102
103  ;=============================================================================
104  ; member* that discovers the last chip first
105  ;=============================================================================
106  (defun member* (element l)
107    (cond
108     ((null l) nil)
109     ((atom (car l))
110      (or (member* element (cdr l)) (eq (car l) element)))
111     (t (or (member* element (cdr l)) (member* element (car l))))
112    )
113  )
114
115  (member* a l1)
116  (member* a l2)
117  (member* a l3)
118  (member* a lat1)
119  (member* a lat2)
120
121  ;=============================================================================
122  ; list+
123  ;=============================================================================
124  (defun list+ (lst)
125    (cond
126     ((null lst) 0)
127     ((consp (car lst)) (+ (list+ (car lst)) (list+ (cdr lst))))
128     (t (+ (car lst) (list+ (cdr lst))))
129    )
130  )
131
132  (list+ '((1 (6 6 (0)))))
133  (list+ '((1 2 (3 6))1))
134  (list+ l3)
135
136  ;=============================================================================
137  ; g* == list+ using accumulator
138  ;=============================================================================
139  (defun g* (lvec acc)
140    (cond
141     ((null lvec) acc)
142     ((atom (car lvec)) (g* (cdr lvec) (+ acc (car lvec))))
143     (t (g* (cdr lvec) (g* (car lvec) acc)))
144    )
145  )
146
147  (g* '((1 (6 6 (0)))) 0)
148  (g* '((1 2 (3 6))1) 0)
149  (g* l3 0)
150
151  ;=============================================================================
152  ; f* == removes duplicates from a list
153  ;=============================================================================
154  (defun f* (lst acc)
155    (cond
156     ((null lst) acc)
157     ((atom (car lst))
158      (cond
159       ((member* (car lst) acc) (f* (cdr lst) acc))
160       (t (f* (cdr lst) (cons (car lst) acc)))
161      )
162     )
163     (t (f* (car lst) (f* (cdr lst) acc)))
164    )
165  )
166
167  (f* l1 (quote()))
168  (f* lat1 (quote()))
169
170  ;=============================================================================
171  ; occur_acc
172  ;=============================================================================
173  (defun occur_acc (element lat acc)
174    (cond
175     ((null lat) acc)
176     ((eq element (car lat)) (occur_acc element (cdr lat) (+ 1 acc)))
177     (t (occur_acc element (cdr lat) acc))
178    )
179  )
180
181  (occur_acc 'a (list 'a 'b 'c 'd 'a 'a 'a) 0)
182  (occur_acc 'a (list 'e 'b 'c 'd 'k 'b 'b) 0)
183  (occur_acc 'a (list 'a 'a 'a 'a 'a 'a 'a) 0)
184
185  ;=============================================================================
186  ; occur*_acc
187  ;=============================================================================
188  (defun occur*_acc (element lst acc)
189    (cond
190     ((null lst) acc)
191     ((consp (car lst)) (occur*_acc element (cdr lst) (occur*_acc element (car lst) acc)))
192     ((eq element (car lst)) (occur*_acc element (cdr lst) (1+ acc)))
193     (t (occur*_acc element (cdr lst) acc))
194    )
195  )
196
197  (occur*_acc a l1 0)
198  (occur*_acc a lat2 0)
199  (occur*_acc a lat1 0)
200  (occur*_acc a l2 0)