ANSI Common Lisp: 3 Lists
June 8, 2003
3.2 Write a version of union that preserves the order of the elements in the original lists.
Solution:
(defun new-union (lst1 lst2)
(cond ((null lst1) lst2)
((null lst2) lst1)
(t (let ((elt (car lst1)))
(if (member elt lst2)
(cons elt (new-union (cdr lst1) (remove elt lst2)))
(cons elt (new-union (cdr lst1) lst2)))))))
cl-user(66): (new-union '(a b c) '(b a d))
(A B C D)
3.3 Define a function that takes a list and returns a list indicating the number of times each (eql) element appears, sorted from most common element to least common.
Solution:
(defun occurrences (lst)
(let ((res (mapcar #'(lambda (elt) (cons elt (count elt lst))) (remove-duplicates lst))))
(sort res #'> :key #'cdr)))
cl-user(2): (occurrences '(a b a d a c d c a))
((A . 4) (D . 2) (C . 2) (B . 1))
3.4 Why does (member '(a) '((a) (b))) return nil?
Solution:
Because the member function compares objects using eql by default. The '(a) and the (a) in '((a) (b)) are distinctive objects although they look the same.
We use override this default by using the :test keyword as follows:
cl-user(150): (member '(a) '((a) (b)) :test #'equal)
((A) (B))
3.5 Suppose the function pos+ takes a list and returns a list of each element plus its position:
> (pos+ '(7 5 1 4))
(7 6 3 7)
Define this function using (a)recursion (b)iteration and (c)mapcar.
Solution:
(a) Recursion
(defun pos+ (lst)
(reverse (rpos+ lst)))
(defun rpos+ (lst)
(if (null lst)
()
(let ((len (length lst)))
(cons (- (+ (car (last lst)) len) 1) (rpos+ (subseq lst 0 (- len 1)))))))
(b) Iteration
(defun pos+ (lst)
(let ((res (copy-list lst)))
(do ((i 0 (+ i 1)))
((= i (length res)) res)
(incf (nth i res) i))))
(c) mapcar
(defun pos+ (lst)
(let ((i -1))
(mapcar #'(lambda (elt)
(incf i)
(+ elt (position elt lst :start i))) lst)))
cl-user(7): (pos+ '(7 5 1 4))
(7 6 3 7)
cl-user(8): (pos+ '(7 5 7 4))
(7 6 9 7)
3.6 After years of deliberation, a government decided that lists should be represented by using cdr to point to the first element and the car to point to the rest of the list. Define the government versions of the following functions: (a) cons (b) list (c) length (d) member.
Solution:
(defun new-cons (x y)
(cons y x))
(defun glist (x &rest y)
(cons y x))
(defun glength (lst)
(+ (length (car lst)) 1))
(defun gmember (x lst)
(if (eql x (cdr lst))
lst
(member x (car lst))))
cl-user(9): (setf a (new-cons 'a 'b))
(B . A)
cl-user(10): (car a)
B
cl-user(11): (cdr a)
A
cl-user(12): (setf b (glist 1 2 3 4 5))
((2 3 4 5) . 1)
cl-user(13): (car b)
(2 3 4 5)
cl-user(14): (cdr b)
1
cl-user(15): (glength b)
5
cl-user(16): (gmember 2 b)
(2 3 4 5)
3.7 Modify the program in Figure 3.6 to use fewer cons cells. (Hints: Use dotted lists.)
Solution:
(defun compress (x)
(if (consp x)
(compr (car x) 1 (cdr x))
x))
(defun compr (elt n lst)
(if (null lst)
(cons (n-elts elt n) nil) ;; change from (list (n-elts elt n))
(let ((next (car lst)))
(if (eql next elt)
(compr elt (+ n 1) (cdr lst))
(cons (n-elts elt n)
(compr next 1 (cdr lst)))))))
(defun n-elts (elt n)
(if (> n 1)
(cons n elt) ;; change from (list n elt)
elt))
cl-user(24): (compress '(1 1 1 0 1 0 0 0 1))
((3 . 1) 0 1 (3 . 0) 1)
3.8 Define a function that takes a list and prints it in dot notation.
Solution:
(defun showdots (lst)
(if (null lst) '())
(dolist (obj lst)
(cond ((atom obj) (format t "(~A . " obj))
(t (format t "(")
(showdots obj)
(format t " . "))))
(format t "NIL")
(dotimes (x (length lst) x)
(format t ")"))
'DONE)
[1] cl-user(29): (showdots '(a b c))
(A . (B . (C . NIL)))
DONE
[1] cl-user(30): (showdots '(a (b c) d))
(A . ((B . (C . NIL)) . (D . NIL)))
DONE
3.9 Write a program to find the longest finite path through a network represented as in Section 3.15. The network may contain cycles.
Solution:
(defun longest-path (start end net)
(bfs end (list (list start)) net))
(defun bfs (end queue net)
(if (null queue)
nil
(let ((path (car queue)))
(let ((node (car path)))
(if (eql node end)
(reverse path)
(bfs end
(append (new-paths path node net) (cdr queue)) ;; different from shortest-path
net))))))
(defun new-paths (path node net)
(mapcar #'(lambda (n)
(if (not (member n path)) ;; check if cycles exist
(cons n path)))
(cdr (assoc node net))))
cl-user(12): (setf min '((a b c) (b c) (c d)))
((A B C) (B C) (C D))
cl-user(13): (longest-path 'a 'd min)
(A B C D)
cl-user(14): (setf min '((a b c) (b a c) (c a d)))
((A B C) (B A C) (C A D))
cl-user(15): (longest-path 'a 'd min)
(A B C D)
1/5