learning-the-little-schemer

stuff.scm (25991B)

---

 (define (dp x . l)
   (cond
    ((null? l) (format #t "~A\n" x))
    (else
     (format #t "~A " x)
     (apply dp l))))
 
 (dp '(a b c)
     '(d e f))
 
 (define (atom? x)
   ;; Originally:
   ; (and (not (pair? x)) (not (null? x)))
   (not (list? x))) 
 
 (define (lat? l)
   (cond
    ((null? l) #t)
    ((atom? (car l)) (lat? (cdr l)))
    (else #f)))
 
 (define (member? a lat)
   (cond
    ((null? lat) #f)
    ((eq? a (car lat)) #t)
    (else (member? a
 		  (cdr lat)))))
 
 (define (member? a lat)
   (cond
    ((null? lat) #f)
    ((equal? a (car lat)) #t)
    (else (member? a
 		  (cdr lat)))))
 
 (define (rember a lat)
   (cond
    ((null? lat) '())
    ((eq? a (car lat)) (cdr lat))
    (else (cons (car lat)
 	       (rember a
 		       (cdr lat))))))
 
 (rember 'a '(b a c d a e))
 (rember 'and '(bacon lettuce and tomato))
 (cons 'bacon (cons 'lettuce '(tomato)))
 
 (null? 1)
 
 (define (firsts l)
   (cond
    ((null? l) '())
    (else (cons (car (car l))
 	       (firsts (cdr l))))))
 
 (firsts '((1 2)
 	  (3 4)
 	  (5 6 7)))
 
 (define (insertR new old lat)
   (cond
    ((null? lat) '())
    ((eq? old (car lat)) (cons old (cons new
 					(cdr lat))))
    (else (cons (car lat)
 	       (insertR new old (cdr lat))))))
 
 (cond
  ((not (equal? (insertR 'e 'd '(a b c d f g d h))
 	       '(a b c d e f g d h)))
   (display "insertR is baaaaad\n")))
 
 (define (insertL new old lat)
   (cond
    ((null? lat) '())
    ((eq? old (car lat)) (cons new
 			      lat) ;; better than (cons new (cons old (cdr lat)))
     )
    (else (cons (car lat)
 	       (insertL new
 			old
 			(cdr lat))))))
 
 (cond
  ((not (equal? (insertL 'e
 			'd
 			'(a b c d f g d h))
 	       '(a b c e d f g d h)))
   (display "insertL is baaaaad\n")))
 
 (define (subst new old lat)
   (cond
    ((null? lat) '())
    ((eq? old (car lat)) (cons new
 			      (cdr lat)))
    (else (cons (car lat)
 	       (subst new
 		      old
 		      (cdr lat))))))
 
 (define (subst2 new o1 o2 lat)
   (cond
    ((null? lat) '())
    ((or (eq? o1
 	      (car lat))
 	(eq? o2
 	     (car lat)))
     (cons new
 	  (cdr lat)))
    (else (cons (car lat)
 	       (subst2 new
 		       o1
 		       o2
 		       (cdr lat))))))
 
 (cond
  ((not (equal? (subst2 'vanilla
 		       'chocolate
 		       'banana
 		       '(banana ice cream with chocolate topping))
 	       '(vanilla ice cream with chocolate topping)))
   (display "subst2 is baaaad\n")))
 
 (define (multirember a lat)
   (cond
    ((null? lat) '())
    ((eq? a
 	 (car lat)) (multirember a
 				 (cdr lat)))
    (else (cons (car lat)
 	       (multirember a
 			    (cdr lat))))))
 
 (cond
  ((not (equal? (multirember 'cup
 			    '(coffee
 			      cup
 			      tea
 			      cup
 			      and
 			      hick
 			      cup))
 	       '(coffee tea and hick)))
   (display "multirember is baaad\n")))
 
 (define (multiinsertR new old lat)
   (cond
    ((null? lat) '())
    ((eq? old
 	 (car lat)) (cons old
 			  (cons new
 				(multiinsertR new
 					      old
 					      (cdr lat)))))
    (else (cons (car lat)
 	       (multiinsertR new
 			     old
 			     (cdr lat))))))
 
 (cond
  ((not (equal? (multiinsertR 'fried
 			     'fish
 			     '(chips
 			       and
 			       fish
 			       or
 			       fish
 			       and
 			       fried))))
   (display "multiinsertR is baaaaaad!!\n")))
 
 (define (multiinsertL new old lat)
   (cond
    ((null? lat) '())
    ((eq? old (car lat)) (cons new (cons old (multiinsertL new old (cdr lat)))))
    (else (cons (car lat) (multiinsertL new old (cdr lat))))))
 
 (multiinsertL 'a 'b '(b c b c b))
 (multiinsertL 'a 'b '(1 2 3))
 
 (define (multisubst new old lat)
   (cond
    ((null? lat) '())
    ((eq? old (car lat)) (cons new (multisubst new old (cdr lat))))
    (else (cons (car lat) (multisubst new old (cdr lat))))))
 
 (multisubst 'a 'b '(b a c b a f b a))
 
 (define (add1 n) (1+ n))
 
 (define (sub1 n) (1- n))
 
 (define (o+ n m)
   (cond
    ((zero? m) n)
    (else (o+ (add1 n) (sub1 m)))))
 
 (o+ 5 3)
 (o+ 3 5)
 
 (o+ 46 12)
 
 (define (o- n m)
   (cond
    ((zero? m) n)
    (else (o- (sub1 n) (sub1 m)))))
 
 (o- 5 3)
 (o- 3 5)
 
 (define (tup? l)
   (cond
    ((null? l) #t)
    ((number? (car l)) (tup? (cdr l)))
    (else #f)))
 
 (tup? '(1 2 3))
 (tup? '(1 2 a))
 (tup? '())
 
 (define (addtup tup)
   (cond
    ((null? tup) 0)
    (else (o+ (car tup) (addtup (cdr tup))))))
 
 (= (addtup '(3 5 2 8)) 18)
 (= (addtup '(15 6 7 12 3)) 43)
 
 (define (o* n m)
   (cond
    ((zero? m) 0)
    (else (o+ n (o* n (sub1 m))))))
 
 (o* 3 5)
 (o* 5 3)
 
 (define (tup+ tup1 tup2)
   (cond
    ((and (null? tup1)
 	 (null? tup2))
     '())
    ((null? tup1) tup2)
    ((null? tup2) tup1)
    (else (cons (o+ (car tup1)
 		   (car tup2))
 	       (tup+ (cdr tup1)
 		     (cdr tup2))))))
 
 (tup+ '(3 6 9 11 4)
       '(8 5 2 0 7))
 (tup+ '(3 6 9 11 4)
       '(8 5 2 0))
 (tup+ '(3 6 9 11)
       '(8 5 2 0 7))
 
 (define (o> n m)
   (cond
    ((zero? n) #f)
    ((zero? m) #t)
    (else (o> (sub1 n)
 	     (sub1 m)))))
 
 (o> 3 5)
 (o> 5 3)
 (o> 3 3)
 
 (define (o< n m)
   (cond
    ((zero? m) #f)
    ((zero? n) #t)
    (else (o< (sub1 n) (sub1 m)))))
 
 (o< 3 5)
 (o< 5 3)
 (o< 3 3)
 
 (define (o= n m)
   (not (or (o< n m) (o> n m))))
 
 (o= 3 5)
 (o= 5 3)
 (o= 3 3)
 
 (define (o^ n m)
   (cond
    ((zero? m) 1)
    (else (o* n (o^ n (sub1 m))))))
 
 (o= (o^ 3 5) 243)
 (o= (o^ 5 3) 125)
 
 (define (odiv n m)
   (cond
    ((o< n m) 0)
    (else (add1 (odiv (o- n m) m)))))
 
 (odiv 10 2)
 (odiv 3 5)
 (odiv 5 3)
 
 (define (olength lat)
   (cond
    ((null? lat) 0)
    (else (add1 (olength (cdr lat))))))
 
 (olength '(1 2 3))
 (olength '())
 
 (define (pick n lat)
   (cond
    ;; turns out we don't define over empty lists, so this is out:
    ;; ((null? lat) '())
    ;;
    ;; and we start counting at 1:
    ((zero? (sub1 n)) (car lat))
    (else (pick (sub1 n) (cdr lat)))))
 
 (pick 1 '(1 2 3))
 
 (define (rempick n lat)
   (cond
    ((zero? (sub1 n)) (cdr lat))
    (else (cons (car lat) (rempick (sub1 n) (cdr lat))))))
 
 (rempick 1 '(a b c))
 (rempick 2 '(a b c))
 (rempick 3 '(a b c))
 
 (define (no-nums lat)
   (cond
    ((null? lat) '())
    ((number? (car lat)) (no-nums (cdr lat)))
    (else (cons (car lat) (no-nums (cdr lat))))))
 
 (equal? (no-nums '(1 2 3 a b c 4 5 6 d e f 7 8 9))
 	'(a b c d e f))
 
 (define (all-nums lat)
   (cond
    ((null? lat) '())
    ((number? (car lat)) (cons (car lat) (all-nums (cdr lat))))
    (else (all-nums (cdr lat)))))
 
 (equal? (all-nums '(1 2 3 a b c 4 5 6 d e f 7 8 9))
 	'(1 2 3 4 5 6 7 8 9))
 
 (define (eqan? a1 a2)
   (cond
    ((and (number? a1) (number? a2)) (o= a1 a2))
    ;; you forgot the case of mixed types, which is very very false (not sure if it makes any sense to include):
    ((or (number? a1) (number? a2)) #f)
    (else (eq? a1 a2))))
 
 (eqan? 1 2)
 (eqan? 2 2)
 (eqan? 'a 'b)
 (eqan? 'a 'a)
 (eqan? 1 'a)
 
 (define (occur a lat)
   (cond
    ((null? lat) 0)
    ((eqan? a (car lat)) (add1 (occur a (cdr lat))))
    (else (occur a (cdr lat)))))
 
 (occur 'a '(a b c d a))
 (occur 'a '(a b c d a 2))
 (occur 2 '(a b c d a 2))
 
 (define (one? n)
   (cond
    ((zero? n) #f)
    ((zero? (sub1 n)) #t)
    (else #f)))
 
 (define (one? n)
   (cond
    ((zero? n) #f)
    (else (zero? (sub1 n)))))
 
 (one? 0)
 (one? 1)
 (one? 2)
 
 (define (rempick n lat)
   (cond
    ((one? n) (cdr lat))
    (else (cons (car lat)
 	       (rempick (sub1 n)
 			(cdr lat))))))
 
 (rempick 1 '(a b c))
 (rempick 2 '(a b c))
 (rempick 3 '(a b c))
 
 (define (rember* a l)
   (cond
    ((null? l) '())
    ((atom? (car l))
     (cond
      ((eqan? a (car l)) (rember* a (cdr l)))
      (else (cons (car l)
 		 (rember* a
 			  (cdr l))))))
    (else (cons (rember* a (car l))
 	       (rember* a (cdr l))))))
 
 (equal? (rember* 'cup '((coffee) cup ((tea) cup) (and (hick)) cup))
 	'((coffee) ((tea)) (and (hick))))
 
 (define (insertR* new old l)
   (cond
    ((null? l) '())
    ((atom? (car l))
     (cond
      ((eqan? old (car l))
       (cons old
 	    (cons new
 		  (insertR* new
 			    old
 			    (cdr l)))))
      (else (cons (car l)
 		 (insertR* new
 			   old
 			   (cdr l))))))
    (else (cons (insertR* new old (car l))
 	       (insertR* new old (cdr l))))))
 
 (equal? (insertR* 'roast 'chuck '((how much (wood))
 				  could
 				  ((a (wood) chuck))
 				  (((chuck)))
 				  (if (a) ((wood chuck)))
 				  could chuck wood))
 	'((how much (wood))
 	  could
 	  ((a (wood) chuck roast))
 	  (((chuck roast)))
 	  (if (a) ((wood chuck roast)))
 	  could chuck roast wood))
 
 (define (insertR* new old l)
   (cond
    ((null? l) '())
    ((atom? (car l))
     (cond
      ((eqan? old (car l))
       (cons old
 	    (cons new
 		  (insertR* new
 			    old
 			    (cdr l)))))
      (else (cons (car l)
 		 (insertR* new
 			   old
 			   (cdr l))))))
    (else (cons (insertR* new old (car l))
 	       (insertR* new old (cdr l))))))
 
 (define (occur* a l)
   (cond
    ((null? l) 0)
    ((atom? (car l))
     (cond
      ((eqan? a (car l)) (add1 (occur* a (cdr l))))
      (else (occur* a (cdr l)))))
    (else (o+ (occur* a (car l))
 	     (occur* a (cdr l))))))
 
 (occur* 'banana '((banana)
 		  (split ((((banana ice)))
 			  (cream (banana))
 			  sherbet))
 		  (banana)
 		  (bread)
 		  (banana brandy)))
 
 (define (subst* new old l)
   (cond
    ((null? l) '())
    ((atom? (car l))
     (cond
      ((eqan? old (car l)) (cons new
 				(subst* new
 					old
 					(cdr l))))
      (else (cons (car l)
 		 (subst* new old (cdr l))))))
    (else (cons (subst* new old (car l))
 	       (subst* new old (cdr l))))))
 
 (equal? (subst* 'orange 'banana '((banana)
 				  (split ((((banana ice)))
 					  (cream (banana))
 					  sherbet))
 				  (banana)
 				  (bread)
 				  (banana brandy)))
 	'((orange)
 	  (split ((((orange ice)))
 		  (cream (orange))
 		  sherbet))
 	  (orange)
 	  (bread)
 	  (orange brandy)))
 
 (define (insertL* new old l)
   (cond
    ((null? l) '())
    ((atom? (car l))
     (cond
      ((eqan? old (car l)) (cons new
 				(cons old
 				      (insertL* new
 						old
 						(cdr l)))))
      (else (cons (car l)
 		 (insertL* new
 			   old
 			   (cdr l))))))
    (else (cons (insertL* new old (car l))
 	       (insertL* new old (cdr l))))))
 
 (equal? (insertL* 'pecker 'chuck '((how much (wood))
 				   could
 				   ((a (wood) chuck))
 				   (((chuck)))
 				   (if (a) ((wood chuck)))
 				   could chuck wood))
 	'((how much (wood))
 	  could
 	  ((a (wood) pecker chuck))
 	  (((pecker chuck)))
 	  (if (a) ((wood pecker chuck)))
 	  could pecker chuck wood))
 
 (define (member* a l)
   (cond
    ((null? l) #f)
    ((atom? (car l))
     (cond
      ((eqan? a (car l)) #t)
      (else (member* a (cdr l)))))
    (else (or (member* a (car l))
 	     (member* a (cdr l))))))
 
 (member* 'chips '((potato) (chips ((with) fish) (chips))))
 (member* 'chips '((potato) (((with) fish) ())))
 
 (define (leftmost l)
   (cond
    ((atom? (car l)) (car l))
    (else (leftmost (car l)))))
 
 (leftmost '((potato) (chips ((with) fish) (chips))))
 (leftmost '(((hot) (tuna (and))) cheese))
 ;; (leftmost '(((() four)) 17 (seventeen))) ;; "No answer."
 ;; (leftmost '()) ;; "No answer."
 ;; "works on non-empty lists that don't contain empty lists."
 
 (define (eqlist? l1 l2)
   (cond
    ;; All are empty:
    ((and (null? l1)
 	 (null? l2))
     #t)
    ;; One of the lists is empty the other is not:
    ((or (null? l1)
 	(null? l2))
     #f)
    ;; All firsts are atoms:
    ((and (atom? (car l1))
 	 (atom? (car l2)))
     (and (eqan? (car l1) (car l2))
 	 (eqlist? (cdr l1)
 		  (cdr l2))))
    ;; One of the firsts is empty, the other is not:
    ((or (atom? (car l1))
 	(atom? (car l2)))
     #f)
    ;; All firsts are lists:
    (else
     (and (eqlist? (car l1) (car l2))
 	 (eqlist? (cdr l1) (cdr l2))))))
 
 (dp "eqlist? empty lists:" (eqlist? '() '()))
 (dp "eqlist? flat lists:"  (eqlist? '(strawberry ice cream) '(strawberry ice cream)))
 (dp (eqlist? '(strawberry ice cream) '(strawberry cream ice)))
 (dp (eqlist? '(banana ((split))) '((banana) (split))))
 
 (define (oequal? s1 s2)
   (cond
    ((and (atom? s1) (atom? s2))
     (eqan? s1 s2))
    ((or (atom? s1) (atom? s2))
     #f)
    (else (eqlist? s1 s2))))
 
 (define (eqlist? l1 l2)
   (cond
    ((and (null? l1)
 	 (null? l2))
     #t)
    ((or (null? l1)
 	(null? l2))
     #f)
    (else (and (oequal? (car l1) (car l2))
 	      (oequal? (cdr l1) (cdr l2))))))
 
 (dp "eqlist? empty lists:" (eqlist? '() '()))
 (dp "eqlist? flat lists:"  (eqlist? '(strawberry ice cream) '(strawberry ice cream)))
 (dp (eqlist? '(strawberry ice cream) '(strawberry cream ice)))
 (dp (eqlist? '(banana ((split))) '((banana) (split))))
 
 (define (rember s l)
     (cond
      ((null? l) '())
      ((atom? (car l))
       (cond 
        ((oequal? s (car l)) (cdr l))
        (else (cons (car l) (rember s (cdr l))))))))
 
 (define (numbered? aexp)
   (cond
    ((atom? aexp) (number? aexp))
    ((= 3 (length aexp))
     (and (numbered? (car aexp))
 	 (numbered? (car (cdr (cdr aexp))))
 	 (or (equal? '+ (car (cdr aexp)))
 	     (equal? '- (car (cdr aexp)))
 	     (equal? '* (car (cdr aexp)))
 	     (equal? '/ (car (cdr aexp)))
 	     (equal? '^ (car (cdr aexp))))))
    (else #f)))
 
 (dp (numbered? 2))
 (dp (numbered? '(2 + 3)))
 (dp (numbered? '((2 * 3) + (10 / 2))))
 (dp (numbered? '((2 * 3) + (10 = 2))))
 
 (define (arg-a nexp) (car nexp))
 (define (arg-b nexp) (caddr nexp))
 (define (op nexp) (cadr nexp))
 
 (define (value nexp)
   (cond
    ((number? nexp) nexp)
    ((equal? '+ (op nexp)) (+ (value (arg-a nexp))
 			     (value (arg-b nexp))))
    ((equal? '- (op nexp)) (- (value (arg-a nexp))
 			     (value (arg-b nexp))))
    ((equal? '* (op nexp)) (* (value (arg-a nexp))
 			     (value (arg-b nexp))))
    ((equal? '/ (op nexp)) (/ (value (arg-a nexp))
 			     (value (arg-b nexp))))
    (else (expt (value (arg-a nexp))
 	       (value (arg-b nexp))))))
 
 (dp (value '((2 * 3) + (10 / 2))))
 
 (define (sero? n)
   (null? n))
 
 (define (edd1 n)
   (cons '() n))
 
 (define (zub1 n)
   (cdr n))
 
 (define (plas n m)
   (cond
    ((sero? m) n)
    (else (plas (edd1 n) (zub1 m)))))
 
 (dp (lat? (list (edd1 '())
 		(edd1 (edd1 '()))
 		(edd1 (edd1 (edd1 '()))))))
 
 (define (set? lat)
   (cond
    ((null? lat) #t)
    ((= 0 (occur (car lat)
 		(cdr lat)))
     (set? (cdr lat)))
    (else #f)))
 
 ;; Theirs' just check existence, not a count.
 (define (set? lat)
   (cond
    ((null? lat) #t)
    ((member? (car lat)
 	     (cdr lat))
     #f)
    (else (set? (cdr lat)))))
 
 (dp (set? '(1 2 3)))
 (dp (set? '(1 2 3 2 5)))
 (dp (set? '(apple 1 2 3 4 5)))
 
 (define (makeseth lat)
   (cond
    ((null? lat) '())
    ((member? (car lat) (cdr lat))
     (cons (car lat)
 	  (makeseth (rember (car lat)
 			    (cdr lat)))))
    (else (cons (car lat)
 	       (makeseth (cdr lat))))))
 
 (dp (makeseth '(apple 1 2 3 2 apple apple 5)))
 
 (define (makeseth lat)
   (cond
    ((null? lat) '())
    ((member? (car lat) (cdr lat))
     (cons (car lat)
 	  (makeseth (multirember (car lat)
 				 (cdr lat)))))
    (else (cons (car lat)
 	       (makeseth (cdr lat))))))
 
 (dp (makeseth '(apple 1 2 3 2 apple apple 5)))
 
 (define (subset? set1 set2)
   (cond
    ((null? set2) (null? set1))
    ((null? set1) #t)
    ((member? (car set1) set2)
     (subset? (cdr set1) set2))
    (else #f)))
 
 (define (subset? set1 set2)
   (cond
    ((null? set1) #t)
    ((member? (car set1) set2)
     (subset? (cdr set1) set2))
    (else #f)))
 
 (define (subset? set1 set2)
   (cond
    ((null? set1) #t)
    ((and (member? (car set1) set2)
 	 (subset? (cdr set1) set2)))
    (else #f)))
 
 (define (subset? set1 set2)
   (cond
    ((null? set1) #t)
    (else (and (member? (car set1) set2)
 	      (subset? (cdr set1) set2)))))
 
 (dp (subset? '() '()))
 (dp (subset? '(1) '()))
 (dp (subset? '() '(1)))
 (dp (subset? '(1) '(1)))
 
 (define (eqset? set1 set2)
   (and (subset? set1 set2)
        (subset? set2 set1)))
 
 (newline)
 
 (dp (eqset? '() '()))
 (dp (eqset? '(1) '()))
 (dp (eqset? '() '(1)))
 (dp (eqset? '(1) '(1)))
 
 (define (intersect? set1 set2)
   (cond
    ((null? set1) #f)
    ((member? (car set1) set2) #t)
    (else (intersect? (cdr set1) set2))))
 
 (define (intersect? set1 set2)
   (cond
    ((null? set1) #f)
    (else (or (member? (car set1) set2)
 	     (intersect? (cdr set1) set2)))))
 
 (define (intersect set1 set2)
   (cond
    ((null? set1) '())
    ((member? (car set1) set2)
     (cons (car set1)
 	  (intersect (cdr set1) set2)))
    (else (intersect (cdr set1) set2))))
 
 (newline)
 
 (dp (intersect '(1 2 3) '(3 4 5)))
 
 (define (union set1 set2)
   (cond
    ((null? set1) set2)
    ((member? (car set1) set2)
     (union (cdr set1) set2))
    (else (cons (car set1)
 	       (union (cdr set1) set2)))))
 
 (dp (union '(1 2 3) '(3 4 5)))
 
 (define (set-difference set1 set2)
   (cond
    ((null? set1) '())
    ((member? (car set1) set2)
     (set-difference (cdr set1) set2))
    (else (cons (car set1)
 	       (set-difference (cdr set1) set2)))))
 
 (define (intersect-all l-set)
   (cond
    ((null? l-set) '())
    ((null? (cdr l-set)) (car l-set))
    (else (intersect (car l-set)
 		    (intersect-all (cdr l-set))))))
 
 (dp (intersect-all '((1 2 3)
 		     (3 4 5)
 		     (3 5 6 7))))
 (dp (intersect-all '((poop pee 23)
 		     (poop pup 23)
 		     (poop pork 23))))
 
 (define (a-pair? l)
   (cond
    ((null? l) #f)
    ((null? (cdr l)) #f)
    ((null? (cdr (cdr l))) #t)
    (else #f)))
 
 ;; Adding an atom case because you cannot cdr a non-cons atom.
 (define (a-pair? l)
   (cond
    ((atom? l) #f)
    ((null? l) #f)
    ((null? (cdr l)) #f)
    ((null? (cdr (cdr l))) #t)
    (else #f)))
 
 (dp (a-pair? '()))
 (dp (a-pair? '(())))
 (dp (a-pair? '(() ())))
 (dp (a-pair? '(() () ())))
 (dp (a-pair? 3))
 
 (define (first p)
   (car p))
 
 (define (second p)
   (car (cdr p)))
 
 (define (build s1 s2)
   (cons s1 (cons s2 '())))
 
 (define (third l)
   (car (cdr (cdr p))))
 
 (define (seconds l)
   (cond
    ((null? l) '())
    (else (cons (second (car l))
 	       (seconds (cdr l))))))
 
 (define (rel? l)
   (cond
    ((null? l) #t)
    ((member? (car l) (cdr l)) #f)
    ((a-pair? (car l)) (rel? (cdr l)))
    (else #f)))
 
 (dp "rel?")
 
 (dp (rel? '()))
 (dp (rel? '((1 2) (1 2))))
 (dp (rel? '((1 2) (1 3))))
 
 (define (fun? rel)
   (cond
    ((null? rel) #t)
    ((member? (second (car rel))
 	     (seconds (cdr rel)))
     #f)
    (else (fun? (cdr rel)))))
 
 (dp "relations and functions:")
 
 (for-each (lambda (l) (dp (list "fun?" l) '= (fun? l)))
 	  '(((4 3) (4 2) (7 6) (6 2) (3 4))
 	    ((1 2) (3 4))
 	    ((1 2) (3 2))))
 
 (define (fun? rel)
   ;; No repeats in the domain of a function.
   (set? (firsts rel)))
 
 (define (revrel rel)
   (cond
    ((null? rel) '())
    (else (cons (build (second (car rel))
 		      (first (car rel)))
 	       (revrel (cdr rel))))))
 
 (for-each (lambda (rel) (dp (list "revrel" rel) '= (revrel rel)))
 	  '(((8 a) (pumpkin pie) (got sick))))
 
 (define (revpair pair)
   (build (second pair)
 	 (first pair)))
 
 (define (revrel rel)
   (cond
    ((null? rel) '())
    (else (cons (revpair (car rel))
 	       (revrel (cdr rel))))))
 
 (for-each (lambda (rel) (dp (list "revrel" rel) '= (revrel rel)))
 	  '(((8 a) (pumpkin pie) (got sick))))
 
 (define (fullfun fun)
   (cond
    ((null? fun) #t)
    (else (set? (seconds fun)))))
 
 (define (fullfun fun)
   (set? (seconds fun)))
 
 (define (rember-f test? a l)
   (cond
    ((null? l) '())
    ((test? a (car l)) (cdr l))
    (else (cons (car l)
 	       (rember-f test?
 			 a
 			 (cdr l))))))
 
 (dp (rember-f equal? 'a '(1 2 a 3)))
 
 (define (rember-f test?)
   (lambda (a l)
     (cond
      ((null? l) '())
      ((test? a (car l)) (cdr l))
      (else (cons (car l)
 		 ((rember-f test?)
 		  a
 		  (cdr l)))))))
 
 (dp ((rember-f equal?) 'a '(1 2 a 3)))
 
 (define (insertL-f test?)
   (lambda (new old lat)
     (cond
      ((null? lat) '())
      ((test? old (car lat))
       (cons new
 	    lat) ;; better than (cons new (cons old (cdr lat)))
       )
      (else (cons (car lat)
 		 ((insertL test?)
 		  new
 		  old
 		  (cdr lat)))))))
 
 (define (insertR test?)
   (lambda (new old lat)
     (cond
      ((null? lat) '())
      ((test? old (car lat))
       (cons old (cons new
 		      (cdr lat))))
      (else (cons (car lat)
 		 ((insertR-f test?)
 		  new
 		  old
 		  (cdr lat)))))))
 
 (define (insert-g-f test?)
   (lambda (direction)
     (lambda (new old lat)
       (cond
        ((null? lat) '())
        ((test? old (car lat))
 	(cond
 	 ((equal? 'left direction)
 	  (cons new lat))
 	 ((equal? 'right direction)
 	  (cons old (cons new
 			  (cdr lat))))))
        (else (cons (car lat)
 		   (((insert-g-f test?) direction)
 		    new
 		    old
 		    (cdr lat))))))))
 
 (define (seqL new old l)
   (cons new (cons old l)))
 
 (define (seqR new old l)
   (cons old (cons new l)))
 
 (define (insert-g-f test?)
   (lambda (seqg)
     (lambda (new old lat)
       (cond
        ((null? lat) '())
        ((test? old (car lat))
 	(seqg new old (cdr lat)))
        (else (cons (car lat)
 		   (((insert-g-f test?) seqg)
 		    new
 		    old
 		    (cdr lat))))))))
 
 (dp (((insert-g-f equal?) seqL) 1 2 '(1 2 3)))
 (dp (((insert-g-f equal?) seqR) 1 2 '(1 2 3)))
 
 (dp "subst seqS:")
 
 (define (seqS new old l)
   (cons new l))
 
 (define (subst new old l)
   ;; XXX: I don't get it. Why won't it work?
   ;; Oh! Now I get it. I did not call the function.
   ;; It just returns the last expression. ~_~
   ((insert-g-f equal?) seqS) new old l)
 
 (dp "Bad version:")
 
 (dp (((insert-g-f equal?) seqS) 2 1 '(1 2 3)))
 (dp (subst 2 1 '(1 2 3)))
 
 (define (subst new old l)
   ;; XXX: This works:
   (((insert-g-f equal?) seqS) new old l))
 
 (dp "Fixed version:")
 
 (dp (((insert-g-f equal?) seqS) 2 1 '(1 2 3)))
 (dp (subst 2 1 '(1 2 3)))
 
 (define subst
   ((insert-g-f equal?) seqS))
 
 (dp "Book version:")
 
 (dp (((insert-g-f equal?) seqS) 2 1 '(1 2 3)))
 (dp (subst 2 1 '(1 2 3)))
 
 (define (seqrem new old l) l)
 
 (define (rember a l)
   (((insert-g-f equal?) seqrem) #f a l))
 
 (dp (rember 2 '(1 2 3)))
 
 (define (atom-to-function atom)
   (cond
    ((equal? atom '+) +)
    ((equal? atom '*) *)
    (else expt)))
 
 (define (value nexp)
   (cond
    ((atom? nexp) nexp)
    (else ((atom-to-function (cadr nexp))
 	  (value (car nexp))
 	  (value (caddr nexp))))))
 
 (dp (value '((2 ^ 3) + (5 * 7))))
 
 (define (multirember-f test?)
   (lambda (a lat)
     (cond
      ((null? lat) '())
      ((test? a (car lat))
       ((multirember-f test?) a (cdr lat)))
      (else (cons (car lat)
 		 ((multirember-f test?) a (cdr lat)))))))
 
 (dp ((multirember-f equal?) 2 '(1 2 3 2)))
 
 (define multirember-eq (multirember-f eq?))
 
 (dp (multirember-eq 2 '(1 2 3 2)))
 
 (define (multiremberT tester? lat)
   (cond
    ((null? lat) '())
    ((tester? (car lat))
     (multiremberT tester?
 		  (cdr lat)))
    (else (cons (car lat)
 	       (multiremberT tester?
 			     (cdr lat))))))
 
 (dp (multiremberT (lambda (x) (equal? 2 x)) '(1 2 3 2)))
 
 (define (multirember-and-co a lat col)
   (cond
    ((null? lat)
     (col '() '()))
    ((equal? a (car lat))
     (multirember-and-co a
 			(cdr lat)
 			(lambda (newlat seen)
 			  (col newlat
 			       (cons (car lat)
 				     seen)))))
    (else
     (multirember-and-co a
 			(cdr lat)
 			(lambda (newlat seen)
 			  (col (cons (car lat) newlat)
 			       seen))))))
 
 (dp (multirember-and-co 'tuna '(strawberries tuna and swordfish) (lambda (x y) (list x))))
 
 (define (multiinsertLR new oldL oldR lat)
   (cond
    ((null? lat) '())
    ((equal? oldL (car lat))
     (cons new
 	  (cons oldL
 		(multiinsertLR new
 			       oldL
 			       oldR
 			       (cdr lat)))))
    ((equal? oldR (car lat))
     (cons oldR
 	  (cons new
 		(multiinsertLR new
 			       oldL
 			       oldR
 			       (cdr lat)))))
    (else (cons (car lat)
 	       (multiinsertLR new
 			      oldL
 			      oldR
 			      (cdr lat))))))
 
 (define (multiinsertLR-and-co new oldL oldR lat col)
   (cond
    ((null? lat)
     (col '() '()))
    ((equal? oldL (car lat))
     (cons new
 	  (cons oldL
 		(multiinsertLR new
 			       oldL
 			       oldR
 			       (cdr lat)
 			       (lambda (newlat seenL seenR)
 				 (col newlat
 				      (cons (car lat)
 					    seenL)
 				      seenR))))))
    ((equal? oldR (car lat))
     (cons oldR
 	  (cons new
 		(multiinsertLR new
 			       oldL
 			       oldR
 			       (cdr lat)
 			       (lambda (newlat seenL seenR)
 				 (col newlat
 				      seenL
 				      (cons (car lat)
 					    seenR)))))))
    (else (cons (car lat)
 	       (multiinsertLR new
 			      oldL
 			      oldR
 			      (cdr lat)
 			      (lambda (newlat seenL seenR)
 				(col (cons (car lat) newlat)
 				     seenL
 				     seenR)))))))
 
 (define (multiinsert-and-co new oldL oldR lat col)
   (cond
    ((null? lat) (col '() 0 0))
    ((equal? oldL (car lat))
     (multiinsert-and-co new
 			oldL
 			oldR
 			(cdr lat)
 			(lambda (newlat l-count r-count)
 			  (col (cons new
 				     (cons oldL newlat))
 			       (1+ l-count)
 			       r-count))))
    ((equal? oldR (car lat))
     (multiinsert-and-co new
 			oldL
 			oldR
 			(cdr lat)
 			(lambda (newlat l-count r-count)
 			  (col (cons oldR
 				     (cons new newlat))
 			       l-count
 			       (1+ r-count)))))
    (else
     (multiinsert-and-co new
 			oldL
 			oldR
 			(cdr lat)
 			(lambda (newlat l-count r-count)
 			  (col (cons (car lat)
 				     newlat)
 			       l-count
 			       r-count))))))
 
 (dp (multiinsert-and-co
      'n
      'l
      'r
      '(a a a l a a a r a a a a r a a a a r)
      (lambda (a b c)
        (list a b c))))
 
 (define (evens-only* l)
   (cond
    ((null? l) '())
    ((atom? (car l))
     (cond
      ((even? (car l))
       (cons (car l) (evens-only* (cdr l))))
      (else
       (evens-only* (cdr l)))))
    (else (cons (evens-only* (car l))
 	       (evens-only* (cdr l))))))
 
 (dp (evens-only* '(1 2 3 4 (2 3 4 5) (5 5 23 2 1))))
 
 ;; Wrap your bloody head around this!
 (define (evens-only-and-co* l col)
   (cond
    ((null? l)
     (col '() 1 0))
    ((atom? (car l))
     (cond
      ((even? (car l))
       (evens-only-and-co* (cdr l)
 			  (lambda (new-evens evens-multiplication odds-sum)
 			    (col (cons (car l)
 				       new-evens)
 				 (* (car l) evens-multiplication)
 				 odds-sum))))
      (else
       (evens-only-and-co* (cdr l)
 			  (lambda (new-evens evens-multiplication odds-sum)
 			    (col new-evens
 				 evens-multiplication
 				 (+ (car l) odds-sum)))))))
    (else
     (evens-only-and-co* (car l)
 			(lambda (new-evens-car evens-multiplication-car odds-sum-car)
 			  (evens-only-and-co* (cdr l)
 					      (lambda (new-evens-cdr evens-multiplication-cdr odds-sum-cdr)
 						(col (cons new-evens-car
 							   new-evens-cdr)
 						     (* evens-multiplication-car
 							evens-multiplication-cdr)
 						     (+ odds-sum-car
 							odds-sum-cdr)))))))))
 
 (dp (evens-only-and-co* '((9 1 2 8) 3 10 ((9 9) 7 6) 2)
 			(lambda (a b c) (cons b (cons c a)))))