The code from "The Little Schemer", translated to Emacs Lisp

little_schemer.el

;;; -*- lexical-binding: t -*-

(defun atom? (x) (not (listp x)))

(atom? 'abc)
(atom? 1)
(atom? '(a b c))

(defun member (a lat)
      (cond ((null lat) nil)
            (t (or (eq (car lat) a) (member a (cdr lat))))
            ))

(member 'a '(b a c))

(defun rember (a lat)
  (cond ((null lat) lat)
        ((eq (car lat) a) (cdr lat))
        (t (cons (car lat) (rember a (cdr lat))))))

(rember 'bacon '(eggs and bacon bacon2))

(defun firsts (lists)
  (cond ((null lists) ())
        (t (cons
            (car (car lists))
            (firsts (cdr lists)))
           )
        )
  )

(firsts '((eggs and bacon) (1 2 3) ((a b) c)))

(defun insertR (new old lat)
  (cond ((null lat) ())
        (t (cond ((eq old (car lat)) (cons old (cons new (cdr lat))))
                 (t (cons (car lat) (insertR new old (cdr lat))))))))

(insertR 'jalapeno 'and '(tamales and salsa))

(defun insertL (new old lat)
  (if (null lat) ()
    (if (eq old (car lat)) (cons new lat)
      (cons (car lat) (insertL new old (cdr lat))))))

(insertL 'jalapeno 'and '(tamales and salsa))

(defun subst2 (new o1 o2 lat)
  (if (null lat) ()
    (if (or (eq (car lat) o1) (eq (car lat) o2)) (cons new (cdr lat))
      (cons (car lat) (subst2 new o1 o2 (cdr lat))))))

(subst2 'vanilla 'chocolate 'banana '(banana ice cream with chocolate topping))

(defun multirember (a lat)
  (if (null lat) ()
    (if (eq a (car lat)) (multirember a (cdr lat))
      (cons (car lat) (multirember a (cdr lat)))
      )))

(multirember 'and '(eggs and bacon and sausages))

(defun multiinsertR (new old lat)
  (if (null lat) ()
    (if (eq old (car lat))
        (cons old (cons new (multiinsertR new old (cdr lat))))
      (cons (car lat) (multiinsertR new old (cdr lat))))))

(multiinsertR 'some 'and
              '(eggs and bacon and sausages))

(defun multiinsertL (new old lat)
  (if (null lat) ()
    (if (eq old (car lat))
        (cons new (cons old (multiinsertL new old (cdr lat))))
      (cons (car lat) (multiinsertL new old (cdr lat))))))

(multiinsertL '(maybe) 'and
              '(eggs and bacon and sausages))

(defun multisubst (new old lat)
  (if (null lat) ()
    (if (eq old (car lat)) (cons new (multisubst new old (cdr lat)))
      (cons (car lat) (multisubst new old (cdr lat))))))

(multisubst '-> 'and '(eggs and bacon and sausages))

(defun plus (n m)
  (if (zerop n) m (plus (1- n) (1+ m))))

(plus '5 '13)

(defun minus (n m)
  (if (zerop m) n (minus (1- n) (1- m))))

(minus '18 '12)

(defun addtup (tup)
  (if (null tup) 0
    (plus (car tup) (addtup (cdr tup)))))

(addtup '(3 4 1 2 5))

(defun times (n m)
  (if (eq n 0) 0
    (plus m (times (1- n) m))))

(times 3 10)

(defun tup+ (tup1 tup2)
  (if (null tup1) tup2
    (if (null tup2) tup1
      (cons (plus (car tup1) (car tup2)) (tup+ (cdr tup1) (cdr tup2)))
      )))

(tup+ '(1 2 5 9) '(4 0 1 12))
(tup+ '(1 2) '(4 0 1 12))
(tup+ '(1 2 5 9) '(4 0))

(defun > (n m)
  (if (zerop n) nil
    (if (zerop m) t
      (> (1- n) (1- m)))))

(> 12 133)
(> 133 12)
(> 10 10)
(> 0 0)

(defun < (n m)
  (if (zerop m) nil
    (if (zerop n) t
      (< (1- n) (1- m)))))

(< 12 133)
(< 133 12)
(< 10 10)
(< 0 0)

(defun pow (base exp)
  (if (zerop exp) 1
    (times base (pow base (1- exp)))
    ))

(pow 1 1)
(pow 2 3)
(pow 5 3)

(defun % (n m)
  (if (< n m) 0
    (1+ (% (minus n m) m))))

(% 15 4)
(% 16 4)

(defun length (lat)
  (if (null lat) 0
    (1+ (length (cdr lat)))))

(length '(hotdogs with mustard sauerkraut and pickles))

(defun pick (n lat)
  (if (zerop (1- n)) (car lat)
    (pick (1- n) (cdr lat))))

(pick 4 '(lasagna spaghetti ravioli macaroni meatball))

(defun rempick (n lat)
  (if (zerop (1- n)) (cdr lat)
    (cons (car lat) (rempick (1- n) (cdr lat)))))

(rempick 3 '(hotdogs with hot mustard))

(defun nonums (lat)
  (if (null lat) ()
    (if (numberp (car lat)) (nonums (cdr lat))
      (cons (car lat) (nonums (cdr lat))))))

(nonums '(5 pears 6 prunes 9 dates))

(defun allnums (lat)
  (if (null lat) ()
    (if (numberp (car lat)) (cons (car lat) (allnums (cdr lat)))
      (allnums (cdr lat)))))

(allnums '(5 pears 6 prunes 9 dates))

(defun eqan? (a1 a2)
  (if (and (numberp a1) (numberp a2)) (= a1 a2)
    (if (or (numberp a1) (numberp a2)) nil
      (eq a1 a2))))

(eqan? 1 1)
(eqan? 'x 'x)
(eqan? 'x 1)

(defun occur (a lat)
  (if (null lat) 0
    (if (eq a (car lat)) (1+ (occur a (cdr lat)))
      (occur a (cdr lat)))))

(occur 1 '(1 2 1 3 4 1 1))

(defun one? (n) (= n 1))

(one? 1)
(one? 2)

(defun rempick (n lat)
  (if (one? n) (cdr lat)
    (cons (car lat) (rempick (1- n) (cdr lat)))))

(rempick 3 '(hotdogs with hot mustard))

(defun rember* (a l)
  (if (null l) ()
    (if (atom? (car l))
        (if (eq a (car l))
            (rember* a (cdr l))
          (cons (car l) (rember* a (cdr l))))
      (cons (rember* a (car l))
            (rember* a (cdr l)))
      )))

(rember* 'sauce '(((tomato sauce)) ((bean) sauce) (and ((flying)) sauce)))

(defun insertR* (new old l)
  (if (null l) ()
    (if (atom? (car l))
        (if (eq (car l) old)
            (cons old (cons new (insertR* new old (cdr l))))
          (cons (car l) (insertR* new old (cdr l))))
      (cons (insertR* new old (car l))
            (insertR* new old (cdr l))))))

(insertR* 'roast 'chuck '((how much (wood))
                          could
                          ((a (wood) chuck))
                          (((chuck)))
                          (if (a) ((wood chuck)))
                          could chuck wood))

(defun occur* (a l)
  (if (null l) 0
    (if (atom? (car l))
        (if (eq a (car l))
            (1+ (occur* a (cdr l)))
          (occur* a (cdr l)))
      (plus (occur* a (car l))
            (occur* a (cdr l)))
      )))

(occur* 'banana '((banana)
                  (split ((((banana ice)))
                          (cream (banana))
                          sherbet))
                  (banana)
                  (bread)
                  (banana brandy)))

(defun subst* (new old l)
  (if (null l) ()
    (if (atom? (car l))
        (if (eq (car l) old)
            (cons new (subst* new old (cdr l)))
          (cons (car l) (subst* new old (cdr l))))
      (cons (subst* new old (car l))
            (subst* new old (cdr l)))
      )))

(subst* 'orange 'banana '((banana)
                          (split ((((banana ice)))
                                  (cream (banana))
                                  sherbet))
                          (banana)
                          (bread)
                          (banana brandy)))

(defun insertL* (new old l)
  (if (null l) ()
    (if (atom? (car l))
        (if (eq (car l) old)
            (cons new (cons old (insertL* new old (cdr l))))
          (cons (car l) (insertL* new old (cdr l))))
      (cons (insertL* new old (car l))
            (insertL* new old (cdr l)))
      )))

(insertL* 'pecker 'chuck '((how much (wood))
                           could
                           ((a (wood) chuck))
                           (((chuck)))
                           ((if) (a) ((wood chuck)))
                           could chuck wood))

(defun member* (a l)
  (if (null l) nil
    (if (atom? (car l))
        (or (eq (car l) a)
            (member* a (cdr l)))
      (or (member* a (car l))
          (member* a (cdr l))))))

(member* 'chips '((potato) (chips ((with) fish) (chips))))

(defun leftmost (l)
  (if (atom? (car l)) (car l)
    (leftmost (car l))))

(leftmost '(((hot) (tuna (and))) cheese))

(defun eqlist? (l1 l2)
  (cond
   ((and (null l1) (null l2)) t)
   ((and (null l1) (atom? (car l2))) nil)
   ((null l1) nil)
   ((and (atom? (car l1)) (null l2)) nil)
   ((and (atom? (car l1)) (atom? (car l2)))
    (and (eqan? (car l1) (car l1)) (eqlist? (cdr l1) (cdr l2))))
   ((atom? (car l1)) nil)
   ((null l2) nil)
   ((atom? (car l2)) nil)
   (t (and (eqlist? (car l1) (car l2))
           (eqlist? (cdr l1) (cdr l2))))))

(defun equal? (l1 l2)
  (cond
   ((and (atom? l1) (atom? l2)) (eqan? l1 l2))
   ((or (atom? l1) (atom? l2)) nil)
   (t (eqlist? l1 l2))))

(equal? 'a 'a)
(equal? '(1 2 3) '(1 2 3))
(equal? '(1 2 3) 'a)

(defun rember (a lat)
  (cond ((null lat) lat)
        ((eq (car lat) a) (cdr lat))
        (t (cons (car lat) (rember a (cdr lat))))))

(defun rember (a l)
  (if (null l) ()
    (if (atom? (car l))
        (if (eq a (car l)) (cdr l)
          (cons (car l) (rember a (cdr l))))
      (if (equal? a (car l)) (cdr l)
        (cons (car l) (rember a (cdr l)))))))

(rember 'bacon '(eggs and bacon bacon))
(rember '(bacon) '(eggs and bacon (bacon)))

(defun rember (a l)
  (if (null l) ()
    (if (equal? (car l) a) (cdr l)
      (cons (car l) (rember a (cdr l))))))

(rember 'bacon '(eggs and bacon bacon))
(rember '(bacon) '(eggs and bacon (bacon)))

(defun rember (a l)
  (cond
   ((null l) ())
   ((equal? (car l) a) (cdr l))
   (t (cons (car l) (rember a (cdr l))))))

(rember 'bacon '(eggs and bacon bacon))
(rember '(bacon) '(eggs and bacon (bacon)))

(defun numbered? (aexp)
  (cond
   ((atom? aexp) (numberp aexp))
   (t (and (numberp (car aexp))
           (numberp (car (cdr (cdr aexp))))))))

(numbered? 1)
(numbered? '(3 + 4))
(numbered? '(3 + foo))

(defun ^ (n m)
  (if (zerop m) 1 (* n (^ n (1- m)))))

(^ 2 3)


(defun value (nexp)
  (cond
   ((atom? nexp) nexp)
   ((eq (car (cdr nexp)) '+)
    (+ (value (car nexp)) (value (car (cdr (cdr nexp))))))
   ((eq (car (cdr nexp)) '*)
    (* (value (car nexp)) (value (car (cdr (cdr nexp))))))
   (t
    (^ (value (car nexp)) (value (car (cdr (cdr nexp))))))))

(value '(3 + 4))
(value '((1 + 2) ^ (3 * 4)))

(defun 1st-sub-exp (aexp) (car (cdr aexp)))
(defun 2nd-sub-exp (aexp) (car (cdr (cdr aexp))))
(defun operator (aexp) (car aexp))

(2nd-sub-exp '(+ 2 3))

(defun value (aexp)
  (cond
   ((atom? aexp) aexp)
   ((eq (operator aexp) '+)
    (+ (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp))))
   ((eq (operator aexp) '-)
    (- (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp))))
   ((eq (operator aexp) '*)
    (* (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp))))
   (t
    (^ (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp))))))

(value '(+ (^ 2 3) 5))


(defun sero? (n) (null n))

(sero? '())
(sero? '(() ()))

(defun edd1 (n) (cons '() n))
(edd1 (edd1 '()))

(defun zub1 (n) (cdr n))
(zub1 (edd1 '(() ())))

(defun pluz (m n)
  (cond
   ((sero? m) n)
   (t (pluz (zub1 m) (edd1 n)))))

(pluz '(() () ()) '(() ()))

(defun set? (lat)
  (cond
   ((null lat) t)
   ((member (car lat) (cdr lat)) nil)
   (t (set? (cdr lat)))))

(set? '(apple peaches apple plum))
(set? '(apples peaches pears plums))

(defun makeset (lat)
  (cond
   ((null lat) ())
   ((member (car lat) (cdr lat)) (makeset (cdr lat)))
   (t (cons (car lat) (makeset (cdr lat))))))

(makeset '(apple peaches apple plum))

(defun makeset (lat)
  (cond
   ((null lat) ())
   (t (cons (car lat)
            (makeset (multirember (car lat) (cdr lat)))))))

(makeset '(apple peach pear peach plum apple lemon peach))

(defun subset? (set1 set2)
  (cond
   ((null set1) t)
   ((member (car set1) set2) (subset? (cdr set1) set2))
   (t nil)))

(subset? '(4 pounds of horseradish)
         '(four pounds chicken and 5 ounces horseradish))

(subset? '(4 pounds of horseradish)
         '(4 pounds of chicken and 5 ounces horseradish))

(defun subset? (set1 set2)
  (if (null set1) t
    (and (member (car set1) set2) (subset? (cdr set1) set2))))

(subset? '(4 pounds of horseradish)
         '(four pounds chicken and 5 ounces horseradish))

(subset? '(4 pounds of horseradish)
         '(4 pounds of chicken and 5 ounces horseradish))

(defun eqset? (set1 set2)
  (and (subset? set1 set2) (subset? set2 set1)))

(eqset? '(6 large chickens with wings)
        '(6 chickens with large wings))

(defun intersect (set1 set2)
  (cond
   ((null set1) ())
   ((member (car set1) set2) (cons (car set1) (intersect (cdr set1) set2)))
   (t (intersect (cdr set1) set2))))

(intersect '(stewed tomatos and macaroni)
           '(macaroni and cheese))

(defun intersect? (set1 set2)
  (if (null set1) nil
    (or (member (car set1) set2) (intersect? (cdr set1) set2))))

(intersect? '(stewed tomatos and macaroni)
            '(macaroni and cheese))

(defun union (set1 set2)
  (cond
   ((null set1) set2)
   (t (cons (car set1) (union (cdr set1) (rember (car set1) set2))))))

(union '(stewed tomatoes and macaroni casserole)
       '(macaroni and cheese))

(defun intersectall (l-set)
  (cond
   ((null (cdr l-set)) (car l-set))
   (t (intersect (car l-set) (intersectall (cdr l-set))))))

(intersectall
 '((6 pears and)
   (3 peaches and 6 peppers)
   (8 pears and 6 plums)
   (and 6 prunes with some apples)))

(defun a-pair? (x)
  (cond
   ((atom? x) nil)
   ((null x) nil)
   ((null (cdr x)) nil)
   ((null (cdr (cdr x))) t)
   (t nil)))

(a-pair? 'bla)
(a-pair? '(x))
(a-pair? '(x y))
(a-pair? '(x y z))

(defun first (p) (car p))
(defun second (p) (car (cdr p)))
(defun build (s1 s2) (cons s1 (cons s2 '())))

(first (build 1 2))
(second (build 1 2))

(defun third (p) (car (cdr (cdr p))))

(defun fun? (rel) (set? (firsts rel)))

(fun? '((d 4) (b 0) (b 9) (e 5) (g 4)))
(fun? '((d 4) (b 0) (e 5) (g 4)))

(defun revpair (p)
  (build (second p) (first p)))
(revpair '(1 2))

(defun revrel (rel)
  (cond
   ((null rel) '())
   (t (cons (revpair (car rel)) (revrel (cdr rel))))))

(revrel '((8 a) (pumpkin pie) (got sick)))

(defun seconds (rel)
  (cond
   ((null rel) '())
   (t (cons (second (car rel)) (seconds (cdr rel))))))

(defun fullfun? (fun)
  (set? (seconds fun)))

(fullfun? '((grape raisin) (plum prune) (stewed grape)))

(defun one-to-one? (fun)
  (fun? (revrel fun)))

(one-to-one? '((grape raisin) (plum prune) (stewed grape)))

(defun rember-f (test? a l)
  (cond
   ((null l) '())
   ((funcall test? (car l) a) (cdr l))
   (t (cons (car l) (rember-f test? a (cdr l))))))

(rember-f (function =) 5 '(6 5 2 3))

(defun eq?-c (a)
  (function (lambda (x) (eq x a))))

(setq eq?-salad (eq?-c 'salad))

; Note that these two calls wouldn't work if we didn't have lexical binding
; enabled (see the first line of this file).
(funcall eq?-salad 'salad)
(funcall eq?-salad 'steak)

(funcall (eq?-c 'salad) 'tuna)

(defun rember-f (test?)
  (lambda (a l)
    (cond
     ((null l) '())
     ((funcall test? (car l) a) (cdr l))
     (t (cons (car l) (funcall (rember-f test?) a (cdr l)))))))

(setq rember-eq? (rember-f 'eq))

(funcall rember-eq? 'tuna '(tuna salad is good))
(funcall (rember-f 'eq) 'salad '(tuna salad is good))

(defun insertR-f (test?)
  (lambda (new old lat)
    (cond ((null lat) ())
          ((funcall test? (car lat) old) (cons old (cons new (cdr lat))))
          (t (cons (car lat)
                   (funcall (insertR-f test?) new old (cdr lat)))))))

(funcall (insertR-f 'eq) 'jalapeno 'and '(tamales and salsa))

(defun insertL-f (test?)
  (lambda (new old lat)
    (cond ((null lat) ())
          ((funcall test? (car lat) old) (cons new (cons old (cdr lat))))
          (t (cons (car lat)
                   (funcall (insertL-f test?) new old (cdr lat)))))))

(funcall (insertL-f 'eq) 'jalapeno 'and '(tamales and salsa))

(defun seqL (new old lat)
  (cons new lat))

(defun seqR (new old lat)
  (cons old (cons new (cdr lat))))

(defun insert-g (seq)
  (lambda (test?)
    (lambda (new old lat)
      (cond ((null lat) ())
            ((funcall test? (car lat) old) (funcall seq new old lat))
            (t (cons (car lat)
                     (funcall (funcall (insert-g seq) test?)
                              new old (cdr lat))))))))

(setq new-insertL-f (insert-g 'seqL))
(setq new-insertR-f (insert-g 'seqR))

(funcall (funcall new-insertR-f 'eq) 'jalapeno 'and '(tamales and salsa))
(funcall (funcall new-insertL-f 'eq) 'jalapeno 'and '(tamales and salsa))

(defun subst (test?)
  (lambda (new old lat)
    (cond ((null lat) ())
          ((funcall test? old (car lat)) (cons new (cdr lat)))
          (t (cons (car lat) (funcall (subst test?) new old (cdr lat)))))))

(funcall (subst 'eq) 'jalapeno 'and '(tamales and salsa))

(defun seqS (new old lat)
  (cons new (cdr lat)))

(setq new-subst (insert-g 'seqS))
(funcall (funcall new-subst 'eq) 'jalapeno 'and '(tamales and salsa))

(defun atom-to-function (x)
  (cond
   ((eq x '+) 'plus)
   ((eq x '*) 'times)
   (t 'pow)))

(atom-to-function '+)
(atom-to-function '*)
(atom-to-function '/)

(defun value (nexp)
  (cond
   ((atom? nexp) nexp)
   (t (funcall (atom-to-function (operator nexp))
               (value (1st-sub-exp nexp))
               (value (2nd-sub-exp nexp))))))

(value '(+ (^ 2 3) 5))

(defun multirember-f (test?)
  (lambda (a lat)
    (cond
     ((null lat) ())
     ((funcall test? a (car lat)) (funcall (multirember-f test?) a (cdr lat)))
     (t (cons (car lat) (funcall (multirember-f test?) a (cdr lat)))))))

(funcall (multirember-f 'eq) 'and '(eggs and bacon and sausages))

(defun multiremberT (test? lat)
  (cond
   ((null lat) '())
   ((funcall test? (car lat)) (multiremberT test? (cdr lat)))
   (t (cons (car lat) (multiremberT test? (cdr lat))))))

(multiremberT (function (lambda (a) (eq a 'and)))
              '(eggs and bacon and sausages))

(multiremberT 'eq '())

(defun multirember&co (a lat col)
  (cond
   ((null lat) (funcall col '() '()))
   ((eq (car lat) a)
    (multirember&co a (cdr lat) (lambda (newlat seen)
                                  (funcall col newlat (cons (car lat) seen)))))
   (t
    (multirember&co a (cdr lat) (lambda (newlat seen)
                                  (funcall col (cons (car lat) newlat) seen))))))

(multirember&co 'tuna '(and tuna) (lambda (newlat seen) (null seen)))
(multirember&co 'tuna '(bird tuna fish tuna tuna) (lambda (l1 l2) (length l2)))

(multirember&co 'tuna '(bird tuna fish tuna tuna) (lambda (l1 l2) l2))
(multirember&co 'tuna '(bird tuna fish tuna tuna) (lambda (l1 l2) l1))


(defun multiinsertLR (new oldL oldR lat)
  (cond
   ((null lat) ())
   ((eq oldL (car lat))
    (cons new (cons oldL (multiinsertLR new oldL oldR (cdr lat)))))
   ((eq oldR (car lat))
    (cons oldR (cons new (multiinsertLR new oldL oldR (cdr lat)))))
   (t (cons (car lat) (multiinsertLR new oldL oldR (cdr lat))))))

(multiinsertLR 'cat 'food 'fluffy '(buy food))
(multiinsertLR 'cat 'food 'fluffy '(fluffy hair))


(defun multiinsertLR&co (new oldL oldR lat col)
  (cond
   ((null lat) (funcall col '() 0 0))
   ((eq oldL (car lat))
    (multiinsertLR&co
     new oldL oldR (cdr lat)
     (lambda (newlat L R)
       (funcall col (cons new (cons oldL newlat)) (1+ L) R))))
   ((eq oldR (car lat))
    (multiinsertLR&co
     new oldL oldR (cdr lat)
     (lambda (newlat L R)
       (funcall col (cons oldR (cons new newlat)) L (1+ R)))))
   (t
    (multiinsertLR&co
     new oldL oldR (cdr lat)
     (lambda (newlat L R) (funcall col (cons (car lat) newlat) L R))))))

(multiinsertLR&co 'cat 'food 'fluffy '(buy fluffy fluffy food)
                  (lambda (newlat L R) newlat))
(multiinsertLR&co 'cat 'food 'fluffy '(buy fluffy fluffy food)
                  (lambda (newlat L R) L))
(multiinsertLR&co 'cat 'food 'fluffy '(buy fluffy fluffy food)
                  (lambda (newlat L R) R))

(defun even? (n)
  (= (* (/ n 2) 2) n))

(even? 7)
(even? 20)

(defun evens-only* (l)
  (cond
   ((null l) '())
   ((atom? (car l)) (cond
                     ((even? (car l)) (cons (car l) (evens-only* (cdr l))))
                     (t (evens-only* (cdr l)))))
   (t (cons (evens-only* (car l)) (evens-only* (cdr l))))))

(evens-only* '((4 7 9) (12 1) () 11 14 15))

(defun evens-only*&co (l col)
  (cond
   ((null l) (funcall col '() 1 0))
   ((atom? (car l))
    (cond
     ((even? (car l)) (evens-only*&co
                       (cdr l)
                       (lambda (newlat newmul newsum)
                         (funcall col (cons (car l) newlat)
                                       (* (car l) newmul)
                                       newsum))))
     (t (evens-only*&co
         (cdr l)
         (lambda (newlat newmul newsum)
           (funcall col
                    newlat newmul (+ (car l) newsum)))))))
   (t (evens-only*&co (car l)
                      (lambda (newlat newmul newsum)
                        (evens-only*&co (cdr l)
                                        (lambda (otherlat othermul othersum)
                                          (funcall col
                                                   (cons newlat otherlat)
                                                   (* newmul othermul)
                                                   (+ newsum othersum)))))))))

(defun the-last-friend (l m s)
  (cons s (cons m l)))

(evens-only*&co '((9 1 2 8) 3 10 ((9 9) 7 6) 2)
                'the-last-friend)

(defun pick (num lat)
  (cond
   ((eq num 1) (car lat))
   (t (pick (1- num) (cdr lat)))))

(defun keep-looking (a sorn lat)
  (cond
   ((numberp sorn) (keep-looking a (pick sorn lat) lat))
   (t (eq sorn a))))

(defun looking (a lat)
  (keep-looking a (pick 1 lat) lat))

(looking 'caviar '(6 2 4 caviar 5 7 3))
(looking 'caviar '(6 2 grits caviar 5 7 3))

(defun shift (pair)
  (build (first (first pair))
         (build (second (first pair))
                (second pair))))

(shift '((a b) (c d)))
(shift '((a b) c))

(defun align (pora)
  (cond
   ((atom? pora) pora)
   ((a-pair? (first pora)) (align (shift pora)))
   (t (build (first pora) (align (second pora))))))

(align '((1 2) (3 4)))

(defun length* (pora)
  (cond
   ((atom? pora) 1)
   (t (+ (length* (first pora)) (length* (second pora))))))

(length* '((1 2) (3 4)))

(defun weight* (pora)
  (cond
   ((atom? pora) 1)
   (t (+ (* (weight* (first pora)) 2) (weight* (second pora))))))

(weight* '((a b) c))
(weight* '(a (b c)))

(defun shuffle (pora)
  (cond
   ((atom? pora) pora)
   ((a-pair? (first pora)) (shuffle (revpair pora)))
   (t (build (first pora)
             (shuffle (second pora))))))

(shuffle '(a (b c)))
(shuffle '(a b))
; (shuffle '((a b) (c d)))

(defun eternity (x)
  (eternity x))

;; Note: in the rest of the code I give names to the various anonymous function
;; that we create leading up to the Y-combinator. This seems somewhat at odds
;; with the goal of the chapter (recursively applying *anonymous* functions),
;; but I do it so that I can easily apply the resulting function to some test
;; arguments.

;; More on the Y combinator: http://www.catonmat.net/blog/derivation-of-ycombinator/

;; length0
(setq length0
      (funcall
       (lambda (lengthfun)
         (lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (funcall lengthfun (cdr l)))))))
       'eternity))

(funcall length0 '())
;; (funcall length0 '(1))

(setq length1
      (funcall
       (lambda (f)
         (lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (funcall f (cdr l)))))))
       (funcall
        (lambda (g)
          (lambda (l)
            (cond
             ((null l) 0)
             (t (1+ (funcall g (cdr l)))))))
        'eternity)))

(funcall length1 '())
(funcall length1 '(1))
;; (funcall length1 '(1 2))

(setq length2
      (funcall
       (lambda (f)
         (lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (funcall f (cdr l)))))))
       (funcall
        (lambda (g)
          (lambda (l)
            (cond
             ((null l) 0)
             (t (1+ (funcall g (cdr l)))))))
        (funcall
         (lambda (h)
           (lambda (l)
             (cond
              ((null l) 0)
              (t (1+ (funcall h (cdr l)))))))
         'eternity))))

(funcall length2 '())
(funcall length2 '(1))
(funcall length2 '(1 2))
;; (funcall length2 '(1 2 3))

(setq length3
      (funcall
       (lambda (k)
         (lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (funcall k (cdr l)))))))
       (funcall
        (lambda (f)
          (lambda (l)
            (cond
             ((null l) 0)
             (t (1+ (funcall f (cdr l)))))))
        (funcall
         (lambda (g)
           (lambda (l)
             (cond
              ((null l) 0)
              (t (1+ (funcall g (cdr l)))))))
         (funcall
          (lambda (h)
            (lambda (l)
              (cond
               ((null l) 0)
               (t (1+ (funcall h (cdr l)))))))
          'eternity)))))

(funcall length3 '())
(funcall length3 '(1))
(funcall length3 '(1 2))
(funcall length3 '(1 2 3))


(setq length0
 (funcall
  (lambda (mk-length)
    (funcall mk-length 'eternity))
  (lambda (length)
    (lambda (l)
      (cond
       ((null l) 0)
       (t (1+ (funcall length (cdr l)))))))))

(funcall length0 '())

(setq length1
      (funcall
       (lambda (mk-length)
         (funcall mk-length (funcall mk-length 'eternity)))
       (lambda (length)
         (lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (funcall length (cdr l)))))))))

(funcall length1 '())
(funcall length1 '(1))

(setq length
      (funcall
       (lambda (mk-length)
         (funcall mk-length mk-length))
       (lambda (mk-length)
         (lambda (l)
           (cond
            ((null l) 0)
            (t (1+ (funcall (funcall mk-length mk-length) (cdr l)))))))))

(funcall length '())
(funcall length '(1))
(funcall length '(1 2))
(funcall length '(1 2 6 7 2 3 5))

(setq y-length
(funcall
 (lambda (le)
   (funcall (lambda (mk-length)
              (funcall mk-length mk-length))
            (lambda (mk-length)
              (funcall le (lambda (x)
                            (funcall
                             (funcall mk-length mk-length) x))))))
 (lambda (length)
   (lambda (l)
     (cond
      ((null l) 0)
      (t (1+ (funcall length (cdr l)))))))))

(funcall y-length '())
(funcall y-length '(1))
(funcall y-length '(1 2))
(funcall y-length '(1 2 6 7 2 3 5))