Back to the list of all chapters

Exercise 1

Exercise 2

(defun new-union (list1 list2)
  (if (consp list2)
      (if (member (car list2) list1)
          (new-union list1 (cdr list2))
          (new-union (append list1 (list (car list2))) (cdr list2)))
      list1))

Exercise 3

(defun occurrences (lst)
  (let ((in (copy-list lst)) (out nil))
       (do ((match (car in) (car in)) (count 0 0))
           ((null in) (sort out #'> :key #'cdr))
         (dolist (ele in)
           (if (eq match ele)
               (setf count (+ count 1))))
         (setf in (remove match in))
         (push (cons match count) out))))

Exercise 4

This function call returns nil because, by default, member tests for equality using eql rather than equal; because the object (a) and the first element of the list ((a) (b)) are two individual conses, they are not considered eql.

In contrast, the function call (member '(a) '((a) (b)) :test #'equal) returns ((a) (b)).

Exercise 5

1. (defun pos+-recursive (lst)
     (pos+-do-recursion 0 lst))
   
   (defun pos+-do-recursion (n lst)
     (if (consp lst)
         (cons (+ (car lst) n) (pos+-do-recursion (+ n 1) (cdr lst)))
         nil))
   

2. (defun pos+-iterative (lst)
     (do ((n 0 (+ n 1)) (lst lst (cdr lst)) (result nil))
         ((null lst) result)
       (setf result (append result (list (+ (car lst) n))))))
   

3. (defun pos+-mapcar (lst)
     (let ((n -1))
       (mapcar #'(lambda (elt) (setf n (+ n 1)) (+ elt n)) lst)))
   

Exercise 6

1. (defun new-cons (a b)
     (cons b a))
   

2. (defun new-list (&rest args)
     (if (null args)
         nil
         (cons (apply #'new-list (cdr args)) (car args))))
   

3. (defun new-length (new-lst)
     (if (null new-lst)
         0
         (+ 1 (new-length (car new-lst)))))
   

4. (defun new-member (object new-prolist)
     (if (null new-prolist)
         nil
         (if (eql (cdr new-prolist) object)
             new-prolist
             (new-member object (car new-prolist)))))
   

Exercise 7

The program can be modified to use fewer cons cells by using dotted lists, by replacing the function n-elts as defined in Figure 3.6 with the following:

(defun n-elts (elt n)
  (if (> n 1)
      (cons n elt)
      elt))

Exercise 8

(defun showdots (lst)
  (format t "~A~%" (getdots lst)))

(defun getdots (lst)
  (if (atom lst)
      lst
      (format nil
              "(~A . ~A)"
              (getdots (car lst))
              (getdots (cdr lst)))))

Exercise 9

This exercise has no solution as stated; there is no longest finite path through a directed graph containing loops. However, if we take Graham to mean the longest non-repeating path through such a network – nodes may be visited multiple times, but no path between nodes may be taken more than once – then the function longest-path below will find the desired path.

(defun longest-path (start end net)
  (reverse (dfs end (list start) net)))

(defun dfs (end path net)
  (if (eql (car path) end)
      path
      (if (null net)
          nil
          (let ((best nil))
            (dolist (next (cdr (assoc (car path) net)) best)
              (let ((best-from-next (dfs end
                                         (cons next path)
                                         (subnet net (car path) next))))
                (if (> (length best-from-next) (length best))
                    (setf best best-from-next))))))))

(defun subnet (net path-from path-to)
  (let ((sub (copy-tree net)))
    (setf (cdr (assoc path-from sub))
          (set-difference (cdr (assoc path-from sub)) (list path-to)))
    sub))