commit 73300be1762eb219138528fa318c7a4f8dd3fcab
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Tue, 14 Nov 2023 23:17:09 +0200
First commit.
Diffstat:
| A | Makefile | | | 2 | ++ |
| A | stuff.scm | | | 1269 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 1271 insertions(+), 0 deletions(-)
diff --git a/Makefile b/Makefile
@@ -0,0 +1,2 @@
+all:
+ guile --no-auto-compile stuff.scm
diff --git a/stuff.scm b/stuff.scm
@@ -0,0 +1,1269 @@
+(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)))))
