path: root/other/little_schemer.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Play-along log to The Little Schemer by Friedman and Felleisen
; Jan 2008, bryan newbold

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Preface: define and test primative

(define atom?
  (lambda (x)
    (and (not (pair? x)) (not (null? x)))))

(atom? (quote ()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 01: Toys

(car '(c b a)) ; returns c
(cdr '(c b a)) ; returns '(b a)
;(car ()) ; gives an error, () is null (but is still a list)

; [[ Law of Car ]]
; The primative car is defind only for non-empty lists.
 
; [[ Law of Cdr ]]
; The primative cdr is defined only for non-empty lists. The cdr of any 
; non-empty list is always another list.

(cons 2 3) ; returns (2 . 3), though book says undefined.
(cons 'a ()) ; returns (a)

; [[ Law of Cons ]]
; The primative cons takes two arguments. The second argument to cons must be
; a list. The result is a list.

(null? ()) ; #t
(null? 3) ; #f
;(null? (() ())); error
;(null? ('() '())) ; error
(null? '(() ())) ; #f
(null? 'asdf) ; #f, book says undefined

;(cdr (1)) ; error!
(cdr '(1)) ; reurns ()

; [[ Law of Null? ]]
; The primative null? is defined only for lists.

; [[ Law of Eq? ]]
; The primative eq? takes two arguments. Each must be a non-numeric atom.

; in practice some numbers can be eq? ?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 02: Do It, Do It Again, and Again, and Again...

(define lat?
  (lambda (l)
    (cond
     ((null? l) #t)
     ((atom? (car l)) (lat? (cdr l)))
     (else #f))))

; lat = list of atoms
(lat? '(a b c d)) ; #t
(lat? '('(1 2 3) 4 5 6)) ; #f
(lat? ()) ; #t

(define member?
  (lambda (a lat)
    (cond
     ((null? lat) #f)
     (else (or (eq? (car lat) a)
	       (member? a (cdr lat)))))))

(member? 'beef '(meat and potatoes and beef)) ; #t
(member? 'tofu ()) ; #f

; {{ The First Commandment }}
; When recurring on a list of atoms, lat, ask two questions about it:
; (null? lat) and else.
; When recurring on a number, n, ask two questions about it: (zero? n) and
; else.
; When recurring on a list of S-expressions, l, ask three questions about it: 
; (null? l), (atom? (car l)), and else.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 03: Cons the Magnificent

(define rember
  (lambda (a lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? (car lat) a) (cdr lat))
     (else (cons (car lat)
		 (rember a (cdr lat)))))))

(rember 'and '(peanut butter and jelly)) ; (peanut butter jelly)

; {{ The Second Commandment }}
; Use cons to build lists.

; returns list of first elements off  each list in a list of lists ;)
(define firsts
  (lambda (l)
    (cond
     ((null? l) ())
     (else (cons (car (car l)) (firsts (cdr l)))))))

(firsts '((a b c) (1 2 3) (j k l))) ; (a 1 j)

; {{ The Third Commandment }}
; When building a list, describe the first typical element, and then
; cons it onto the natural recursion.

(define insertR
  (lambda (new old lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? old (car lat)) (cons (car lat) (cons new (cdr lat))))
     (else (cons (car lat) (insertR new old (cdr lat)))))))

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

(define insertL
  (lambda (new old lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? old (car lat)) (cons new lat))
     (else (cons (car lat) (insertL new old (cdr lat)))))))

(insertL 'now 'please '(do it please)) ; (do it now please)

(define subst
  (lambda (new old lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? old (car lat)) (cons new (cdr lat)))
     (else (cons (car lat) (subst new old (cdr lat)))))))

(subst 'both 'and '(meat and potatoes)) ; (meat both potatoes)

(define subst2
  (lambda (new o1 o2 lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? o1 (car lat)) (cons new (cdr lat)))
     ((eq? o2 (car lat)) (cons new (cdr lat)))
     (else (cons (car lat) (subst2 new o1 o2 (cdr lat)))))))

(subst2 'a 'q 'r '(a s d r q)) ; (a s d a q)
(subst2 'a 'q 'r '(a s q d r)) ; (a s a d r)

(define multirember
  (lambda (a lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? (car lat) a) (multirember a (cdr lat)))
     (else (cons (car lat) (multirember a (cdr lat)))))))

(multirember 'd '(a d b d s g r c d d d w r)) ; (a b s g r c w r)

; {{ The Fourth Commandment }}
; Always change at least one argument while recurring. It must be changed to
; be closer to termination. The changing argument must be tested in the
; termination condition: when using cdr, test temrination with null?.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 04: Numbers Games

(atom? 0) ; #t
(atom? 3.123123132) ; #t
(atom? -12i) ; #t

(define add1
  (lambda (n)
    (+ n 1)))

(add1 67)

(define sub1
  (lambda (n)
    (- n 1)))

(sub1 0) ; -1
(sub1 -12i) ; -1-12i
(sub1 +2i) ; -1+2i

(zero? 2) ; #f

; doesn't handle negatives!
(define o+
  (lambda (a b)
    (cond
     ((zero? b) a)
     (else (o+ (add1 a) (sub1 b))))))

(o+ 12 3)

(define o-
  (lambda (a b)
    (cond
     ((zero? b) a)
     (else (o- (sub1 a) (sub1 b))))))

(o- 12 3) ; 9
(o- 10 25) ; -15
;(o- 4 -1) ; infinite loop!

(zero? ()) ; #f

(define addtup
  (lambda (tup)
    (cond
     ((null? tup) 0)
     (else (o+ (car tup) (addtup (cdr tup)))))))

(addtup '(1 1 1 1 1)) ; 5
(addtup '()) ; 0

(define ox
  (lambda (a b)
    (cond
     ((zero? b) 0)
     (else (o+ a (ox a (sub1 b)))))))

(ox 4 4) ; 16
;(ox 12983761498 12983472) ; max recursion depth exceeded ;(
;(ox 39485 345) ; SLOW!

; {{ The Fourth Commandment }}
; Always change at least one argument while recurring. It must be changed to be
; closer to termination. The changing argument must be tested in the 
; termination condition: 
; when using cdr, test termination with null? and
; when using sub1, test termination with zero?.

; {{ The Fifth Commandment }}
; When building a value with +, always use 0 for the value of the terminating
; line, for adding 0 does not change the value of an addition.
; When building a value with x, always use 1 for the value of the terminating
; line, for multiplying by 1 does not change the value of a multiplication.
; When building a value with cons, always condsider () for the value of the
; terminating line.

(define tup+
  (lambda (a b)
    (cond
     ((or (null? a) (null? b)) ())
     (else (cons (o+ (car a) (car b)) (tup+ (cdr a) (cdr b)))))))
; the book uses 'and' instead of 'or' because it specifies the tups must
; be of equal length

(tup+ '(1 2 3 4 5) '(5 4 3 2 1)) ; (6 6 6 6 6)

; improved version
(define tup+
  (lambda (a b)
    (cond
     ((and (null? a) (null? b)) (quote ()))
     ((null? a) b)
     ((null? b) a)
     (else (cons (o+ (car a) (car b)) (tup+ (cdr a) (cdr b)))))))

(tup+ '(1 2 3 4 5) '(5 4)) ; (6 6 3 4 5)

(define o> 
  (lambda (a b)
    (cond
     ((zero? a) #f)
     ((zero? b) #t)
     (else (o> (sub1 a) (sub1 b))))))

(o> 5 6) ; #t
(o> 7 7) ; #f

(define length
  (lambda (lat)
    (cond
     ((null? lat) 0)
     (else (add1 (length (cdr lat)))))))
(length '(a b c d)) ; 4
(length (quote ())) ; 0

(define pick
  (lambda (n lat)
    (cond 
     ((zero? (sub1 n)) (car lat))
     (else (pick (sub1 n) (cdr lat))))))

(define rempick
  (lambda (n lat)
    (cond
     ((null? lat) (quote ()))
     ((zero? n) (cdr lat))
     (else (cons (car lat) (rempick (sub1 n) (cdr lat)))))))

(rempick 3 `(this sentance has like a billion words))

(define no-nums
  (lambda (lat)
    (cond
     ((null? lat) (quote ()))
     ((number? (car lat)) (no-nums (cdr lat)))
     (else (cons (car lat) (no-nums (cdr lat)))))))

(no-nums '(this 1 sentance has 56 other numbers 23 built-in))

(define all-nums
  (lambda (lat)
    (cond
     ((null? lat) (quote ()))
     ((number? (car lat)) (cons (car lat) (all-nums (cdr lat))))
     (else (all-nums (cdr lat))))))

(all-nums '(this 1 sentance has 56 other numbers 23 built-in))

(define eqan?
  (lambda (a b)
    (cond
     ((and (number? a) (number? b)) (= a b))
     ((or (number? a) (number? b)) #f)
     (else (eq? a b)))))

(eq? 1 1) ; #t
(eqan? 2 3) ; #f

(define occur
  (lambda (a lat)
    (cond
     ((null? lat) 0)
     ((eq? a (car lat)) (add1 (occur a (cdr lat))))
     (else (occur a (cdr lat))))))

(occur 'n '(a n d that's all n folks!)) ; 2
(occur 123 '(1 2 3 4)) ; 0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 05: Oh My Gawd: It's full of Stars

(define rember*
  (lambda (a l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (cond
		       ((eq? a (car l)) (cdr l))
		       (else (cons (car l) (rember* a (cdr l))))))
     (else (cons (rember* a (car l)) (rember* a (cdr l)))))))

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

(define insertR*
  (lambda (new old l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (cond
		       ((eq? old (car l)) (cons (car l) (cons new (cdr l))))
		       (else (cons (car l) (insertR* new old (cdr l))))))
     (else (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))

(define occur*
  (lambda (a l)
    (cond
     ((null? l) 0)
     ((atom? (car l)) (cond 
		       ((eq? (car l) a) (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*
  (lambda (new old l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (cond
		       ((eq? 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)))))))

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

(define insertL*
  (lambda (new old l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (cond
		       ((eq? old (car l)) 
			(cons new (cons
				   (car l)
				   (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)))))))

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

(define member*
  (lambda (a l)
    (cond
     ((null? l) #f)
     ((atom? (car l)) (cond
		       ((eq? 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))))) ; #t
(member* 'beef '(meat ((and potatoes)) (with brocolli))) ; #f

; list must not contain null list!
(define leftmost
  (lambda (l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (car l))
     (else (leftmost (car l))))))

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

(define eqlist?
  (lambda (a b)
    (cond
     ((and (null? a) (null? b)) #t)
     ((or (null? a) (null? b)) #f)
     ((and (atom? (car a)) (atom? (car b))) 
      (and (eqan? (car a) (car b))
	   (and (eqlist? (cdr a) (cdr b)))))
     ((or (atom? (car a)) (atom? (car b))) #f)
     (else (and (eqlist? (car a) (car b)) (eqlist? (cdr a) (cdr b)))))))

(eqlist?
 '(beef ((sausage)) (and (soda)))
 '(beef ((sausage)) (and (soda)))) ; #t

(eqlist?
 '(beef ((sausag)) (and (soda)))
 '(beef ((sausage)) (and))) ; #f

(eqlist? '(ff (1 2) (a)) '(ff (1 2) (b))) ; #f

(eqan? 'sausag 'sausage) ; #f

; new definition allows removal of S-expressions
(define rember
  (lambda (s l)
    (cond 
     ((null? l) (quote ()))
     ((equal? s (car l)) (cdr l))
     (else (cons (car l) (rember s (cdr l)))))))

; these next two I just copied after the fact, didn't think I would
; need them at the time
(define equal?
  (lambda (a b)
    (cond
     ((and (atom? a) (atom? b)) (eqan? a b))
     ((or (atom? a) (atom? b)) #f)
     (else (eqlist? a b)))))

(equal? '(this ((is more) complicated))
	'(this ((is more) complicated))) ; #t
(equal? '(this ((is more) complicated))
	'(this ((is) complicated))) ; #f
(equal? '4' '(4 5)) ; #f

(define rember
  (lambda (s l)
    (cond
     ((null? l) (quote ()))
     ((equal? (car l) s) (cdr l))
     (else (cons (car l) (rember s (cdr l)))))))

(rember 'q '(a b e d q))
(rember '4 '(1 2 3 (4 5) 8))
(rember '(4 5) '(1 2 3 (4 5) 6 7 8))

; {{ The Sixth Commandment }}
; Simplify only after the function is correct.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 06: Shadows

(define numbered?
  (lambda (aexp)
    (cond
     ((null? aexp) #f)
     ((atom? aexp) (number? aexp))
     ((or (eq? (car (cdr aexp)) (quote +))
	  (eq? (car (cdr aexp)) (quote -))
	  (eq? (car (cdr aexp)) (quote ^)))
      (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp))))))
     (else #f))))

(numbered? '(1 + 3)) ; #t
(numbered? '((4 ^ 3) - 4)) ; #t
(numbered? '(a + 2 + (r ^ 2))) ; #f
(numbered? '(1 _ 3 + 5 + Q)) ; #f
(numbered? '(1 + 4 ^ 8 + r)) ; #t???? should only have two expressions
(numbered? '((1 + 4) ^ (8 + r))) ; #f

;book likes to make assumptions, namely that aexp is definately an algebraic
;expression
(define numbered?
  (lambda (aexp)
    (cond
     ((atom? aexp) (number? aexp))
     (else (and (numbered? (car aexp))
		(numbered? (car (cdr (cdr aexp)))))))))

(numbered? '1)
(numbered? '(1 + 1))


(define value
  (lambda (aexp)
    (cond
     ((atom? aexp) aexp)
     ((eq? (car (cdr aexp)) (quote +)) (+ (value (car aexp))
					  (value (car (cdr (cdr aexp))))))
     ((eq? (car (cdr aexp)) (quote -)) (- (value (car aexp))
					  (value (car (cdr (cdr aexp))))))
     ((eq? (car (cdr aexp)) (quote ^)) 
      (expt (value (car aexp))
	    (value (car (cdr (cdr aexp)))))))))

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

(define 1st-sub-exp
  (lambda (aexp)
    (car aexp)))

(define 2nd-sub-exp
  (lambda (aexp)
    (car (cdr (cdr aexp)))))

(define operator
  (lambda (aexp)
    (car (cdr aexp))))

; {{ The Seventh Commandment }}
; Recur on the subpart that are of the same nature:
; * on the sublists of a list.
; * on the subexpressions of an arthmetic expression.

; {{ The Eighth Commandment }}
; Use help functions to abstract from representations.

(define sero?
  (lambda (n)
    (null? n)))

(sero? '()) ; #t
(sero? '(() ())) ; #f

(define edd1
  (lambda (n)
    (cons (quote ()) n)))

(define zub1
  (lambda (n)
    (cdr n)))

;(define o+
;  (lambda (n m)
;    (cond
;     ((sero? m) n)
;     (else (edd1 (o+ n (zub1 m)))))))

;(o+ '(() ()) '(() () ())) ; (() () () () ())

;(lat? (() () () () ())) ; error!

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 07: Friends and Relations

(define set?
  (lambda (lat)
    (cond
     ((null? lat) #t)
     ((member? (car lat) (cdr lat)) #f)
     (else (set? (cdr lat))))))

(set? '(this is a sentance with no repeats)) ; #t
(set? '()) ; #t
(set? '(this is a sentance with repeats, so this is not a set)); #f

(define makeset
  (lambda (lat)
    (cond
     ((null? lat) (quote ()))
     ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
     (else (cons (car lat) (makeset (cdr lat)))))))

(makeset '(a b c b c c c d e f))

; is every element of the first in the second?
(define subset?
  (lambda (a b)
    (cond
     ((null? a) #t)
     ((member? (car a) b) (subset? (cdr a) b))
     (else #f))))

(subset? '() '(1 2 3)) ; #t
(subset? '(a b c) '(1 4 b 6 c 1 a)) ; #t
(subset? '(a b c) '(1 4 b 6 1 a)) ; #f

(define eqset?
  (lambda (a b)
    (and (subset? a b) (subset? b a))))

(eqset? '(1 2 3 4) '(3 4 1 2)) ; #t
(eqset? '(1 2 3 4 5) '(3 4 1 2)) ; #f

(define intersect? 
  (lambda (a b)
    (cond
     ((null? a) #f)
     (else (or (member? (car a) b) (intersect? (cdr a) b))))))

(intersect? '(a b c) '(1 2 3)) ; #f
(intersect? '(a B c) '(1 2 3 B 5)) ; #t

(define intersect
  (lambda (a b)
    (cond
     ((null? a) (quote ()))
     ((member? (car a) b) (cons (car a) (intersect (cdr a) b)))
     (else (intersect (cdr a) b)))))

(intersect '(a b c) '(1 2 3)) ; ()
(intersect '(a b c) '(1 b c 4 5)) ; (b c)

(define union
  (lambda (a b)
    (cond
     ((null? a) b)
     ((member? (car a) b) (union (cdr a) b))
     (else (union (cdr a) (cons (car a) b))))))

(union '(a b c) '(1 2 3))
(union '(a b c) '(a b 3))

(define intersectall 
  (lambda (l-set)
    (cond
     ((null? (cdr l-set)) (car l-set))
     (else (intersect (car l-set) (intersectall (cdr l-set)))))))

(intersectall '((a b c) (c a d e) (e f g h a b))) ; (a)

(define a-pair?
  (lambda (x)
    (cond
     ((null? x) #f)
     ((atom? x) #f)
     ((null? (cdr x)) #f)
     ((null? (cdr (cdr x))) #t)
     (else #f))))

(define first
  (lambda (p) (car p)))

(define second 
  (lambda (p) (car (cdr p))))

(define build
  (lambda (a b) (cons a (cons b (quote ())))))

(define third
  (lambda (p) (car (cdr (cdr p)))))

; a rel is a relation: a list of pairs

(firsts '((a b) (c d) (e f))) ; # (a c e), from an earlier chapter

(define fun?
  (lambda (rel)
    (set? (firsts rel))))

(define revrel
  (lambda (rel)
    (cond
     ((null? rel) (quote ()))
     (else (cons (build (second (car rel)) (first (car rel)))
		 (revrel (cdr rel)))))))

(revrel '((a b) (1 2) (here there)))

(define revpair
  (lambda (p)
    (build (second p) (first p))))

(define revrel
  (lambda (rel)
    (cond
     ((null? rel) (quote ()))
     (else (cons (revpair (car rel)) (revrel (cdr rel)))))))

(define fullfun?
  (lambda (fun)
    (set? (seconds fun))))

(define one-to-one?
  (lambda (fun)
    (fun? (revrel fun))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 08: Lambda the Ultimate

(define rember-f
  (lambda (test? a l)
    (cond
     ((null? l) (quote ()))
     ((test? a (car l)) (rember-f test? a (cdr l)))
     (else (cons (car l) (rember-f test? a (cdr l)))))))

(rember-f equal? '(pop corn) '(lemonade (pop corn) and (cake)))

; Currying: Moses Schonfinkel and Haskell Curry

(define eq?-c
  (lambda (a)
    (lambda (x)
      (eq? x a))))

((eq?-c 'salad) 'salad) ; #t
(define eq?-salad (eq?-c 'salad))
(eq?-salad 'salad) ; #t

(define rember-f
  (lambda (test?)
    (lambda (a l)
      (cond
       ((null? l) (quote ()))
       ((test? a (car l)) ((rember-f test?) a (cdr l)))
       (else (cons (car l) ((rember-f test?) a (cdr l))))))))

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

(define insertL-f
  (lambda (test?)
    (lambda (new old l)
      (cond
       ((null? l) (quote ()))
       ((test? (car l) old)
	(cons new (cons old (cdr l))))
       (else (cons (car l)
		   ((insertL-f test?) new old (cdr l))))))))

(define seqL
  (lambda (new old l)
    (cons new (cons old l))))

(define seqR
  (lambda (new old l)
    (cons old (cons new l))))

(define insert-g
  (lambda (seq)
    (lambda (new old l)
      (cond
       ((null? l) (quote ()))
       ((eq? (car l) old) (seq new old (cdr l)))
       (else (cons (car l) ((insert-g seq) new old (cdr l))))))))

(define insertL (insert-g seqL))
(define insertR (insert-g seqR))
(define insertL (insert-g
		 (lambda (new old l)
		   (cons new (cons old l)))))

(insertL 'BUT 'then '(where but for the end then))

(define seqS
  (lambda (new old l) (cons new l)))

(define subst (insert-g seqS))

(subst 'both 'and '(meat and potatoes))

; {{ The Ninth Commandment }}
; Abstract common patterns with a new function.

(define atom-to-function
  (lambda (x)
    (cond
     ((eq? x (quote +)) +)
     ((eq? x (quote x)) ox)
     (else expt))))

(expt 4 4) ; 256
(+ 4 4) ; 8
(ox 4 4)
(o+ 4 4)

(atom-to-function (operator '(+ 5 3))) ; plus function

(define value
  (lambda (nexp)
    (cond
     ((atom? nexp) nexp)
     (else
      ((atom-to-function (operator nexp))
       (value (1st-sub-exp nexp))
       (value (2nd-sub-exp nexp)))))))

(value '(4 + 2))

(define multirember-f
  (lambda (test?)
    (lambda (a lat)
      (cond
       ((null? lat) (quote ()))
       ((test? a (car lat)) ((multirember-f test?) a (cdr lat)))
       (else (cons (car lat) ((multirember-f test?) a (cdr lat))))))))

((multirember-f eq?) 'tuna '(shrimp salad tuna salad and tuna))

(define eq?-tuna (eq?-c (quote tuna)))
(eq?-tuna (quote tuna)) ; #t

(define multiremberT
  (lambda (test? lat)
    (cond
     ((null? lat) (quote ()))
     ((test? (car lat)) (multiremberT test? (cdr lat)))
     (else (cons (car lat) (multiremberT test? (cdr lat)))))))

(multiremberT eq?-tuna '(shrimp salad tuna salad and tuna))

(define a-friend
  (lambda (x y)
    (null? y)))

; col is a collector

(define multirember&co
  (lambda (a lat col)
    (cond
     ((null? lat) (col (quote ()) (quote ())))
     ((eq? (car lat) a) (multirember&co 
			 a 
			 (cdr lat)
			 (lambda (newlat seen)
			   (col newlat (cons (car lat) seen)))))
     (else (multirember&co a (cdr lat) 
			   (lambda (newlat seen)
			     (col (cons (car lat) newlat) seen)))))))

(define new-friend
  (lambda (newlat seen)
    (a-friend newlat (cons (quote tuna) seen))))

; {{ The Tenth Commandment }}
; Build functions to collect more than one value at a time.

(define multiinsertL
  (lambda (new old lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? (car lat) old) (cons new
				(multiinsertL new old (cdr lat))))
     (else (cons (car lat) (multiinsertL new old (cdr lat)))))))

(define multiinsertR
  (lambda (new old lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? (car lat) old) (cons new
				(multiinsertR new old (cdr lat))))
     (else (cons (car lat) (multiinsertR new old (cdr lat)))))))

(define multiinsertLR
  (lambda (new oldL oldR lat)
    (cond
     ((null? lat) (quote ()))
     ((eq? (car lat) oldL) 
      (cons new (cons oldL
		      (multiinsertLR new oldL oldR (cdr lat)))))
     ((eq? (car lat) oldR)
      (cons new (multiinsertLR new oldL oldR (cdr lat))))
     (else (cons (car lat) (multiinsertLR new oldL oldR (cdr lat)))))))

(define multiinsertLR&co
 (lambda (new oldL oldR lat col)
   (cond
    ((null? lat) (col (quote ()) 0 0))
    ((eq? (car lat) oldL) 
     (multiinsertLR&co new oldL oldR (cdr lat)
		       (lambda (newlat L R)
			 (col (cons new
				    (cons oldL newlat)) (add1 L) R))))
    ((eq? (car lat) oldR)
     (multiinsertLR&co new oldL oldR (cdr lat)
		       (lambda (newlat L R)
			 (col (cons oldR (cons new newlat)) L (add1 R)))))
    (else (multiinsertLR&co new oldL oldR
			    (cdr lat)
			    (lambda (newlat L R)
			      (col (cons (car lat) newlat)
				   L R)))))))

(multiinsertLR&co 'salty 'fish 'chips
		  '(chips and fish or fish and chips)
		  (lambda (lat L R)
		    R)) ; 2

(multiinsertLR&co 'salty 'fish 'chips
		  '(chips and fish or fish and chips)
		  (lambda (lat L R)
		    lat))

(define even?
  (lambda (n)
    (= (* (round (/ n 2)) 2) n)))

(round 3/2) ; 2
(= 1 1) ; #t
(/ 4 2) ; 2
(* 4 2) ; 8
(even? 3) ; #f

(define evens-only*
  (lambda (l)
    (cond
     ((null? l) (quote ()))
     ((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)))))))

(evens-only* '((9 1 2 8) 3 10 ((9 9) 7 6) 2))
; ((2 8) 10 (() 6) 2)

(define col-odds
  (lambda (l p s) l))

(define col-p
  (lambda (l p s) p))

(define col-s
  (lambda (l p s) s))

(define evens-only*&co
  (lambda (l col)
    (cond
     ((null? l) (col (quote ()) 1 0))
     ((atom? (car l)) 
      (cond
       ((even? (car l)) (evens-only*&co (cdr l)
					(lambda (newl p s)
					  (col (cons (car l) newl)
					       (* p (car l))
					       s))))
       (else (evens-only*&co (cdr l)
			     (lambda (newl p s)
			       (col newl
				    p
				    (+ s (car l))))))))
     (else
      (evens-only*&co (car l)
		      (lambda (al ap as)
			(evens-only*&co (cdr l)
					(lambda (dl dp ds)
					  (col (cons al dl)
					       (* ap dp)
					       (+ as ds))))))))))

(evens-only*&co '((9 1 2 8) 3 10 ((9 9) 7 6) 2)
		(lambda (newl p s)
		  (cons s (cons p newl)))) ; (38 1920 (2 8) 10 (() 6) 2)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 09: ... and Again, and Again, and Again, ...

(define looking
  (lambda (a lat)
    (keep-looking a (pick 1 lat) lat)))

; sorn is a symbol or a number

(define keep-looking
  (lambda (a sorn lat)
    (cond
     ((number? sorn) (keep-looking a (pick sorn lat) lat))
     (else (eq? sorn a)))))

(looking 'caviar '(6 2 4 caviar 5 7 3)) ; #t
(looking 'caviar '(6 2 grits caviar 5 7 3)) ; #f

; total functions terminate for all finite inputs?
; partial functions terminate for only some inputs?

(define shift
  (lambda (pair)
    (build (first (first pair))
	   (build (second (first pair))
		  (second pair)))))

(shift '((a b) c)); (a (b c))
;(shift '(a (b c))); error

; pora = pair or atom
(define align
  (lambda (pora)
    (cond
     ((atom? pora) pora)
     ((a-pair? (first pora)) (align (shift pora)))
     (else (build (first pora) (align (second pora)))))))

(define length*
  (lambda (pora)
    (cond
     ((atom? pora) l)
     (else (length* (first pora)) (length* (second pora))))))

(define weight*
  (lambda (pora)
    (cond
     ((atom? pora) 1)
     (else (+ (* 2 (weight* (first pora)))
	      (weight* (second pora)))))))

(weight* '((a b) c)) ; 7
(weight* '(a (b c))) ; 5

(define shuffle
  (lambda (pora)
    (cond
     ((atom? pora) pora)
     ((a-pair? (first pora)) (shuffle (revpair pora)))
     (else (build (first pora) (shuffle (second pora)))))))

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

; Collatz function?
(define C
  (lambda (n)
    (cond
     ((one? n) 1)
     (else (cond
	    ((even? n) (C (/ n 2)))
	    (else (C (add1 (* 3 n)))))))))

; (C 0) ; infinite recursion?
(C 1) ; 1
(C 2) ; 1
(C 8) ; 1

; Ackermann function
(define A
  (lambda (n m)
    (cond
     ((zero? n) (add1 m))
     ((zero? m) (A (sub1 n) 1))
     (else (A (sub1 n) (A n (sub1 m)))))))

(A 1 0) ; 2
(A 2 2) ; 7
(A 3 3) ; 61
(A 3 4) ; 125
; (A 4 3) ; ocean boiling?

(define eternity
  (lambda (x) (eternity x)))

; got lost here a bit...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 10: What is the Value of All of This?

(define new-entry build)

(define lookup-in-entry
  (lambda (name entry entry-f)
    (lookup-in-entry-help name
			  (first entry)
			  (second entry)
			  entry-f)))

(define lookup-in-entry-help
  (lambda (name names values entry-f)
    (cond
     ((null? names) (entry-f name))
     ((eq? (car names) name) (car values))
     (else (lookup-in-entry-help name (cdr names) (cdr values) entry-f)))))

(lookup-in-entry 'fish
		 '((teach a man to fish)
		   (1 2 3 4 5))
		 (lambda (x) x))

(define extend-table cons)

(define lookup-in-table
  (lambda (name table table-f)
    (cond
     ((null? table) (table-f name))
     (else (lookup-in-entry name 
			    (car table)
			    (lambda (n)
			      (lookup-in-table n (cdr table) table-f)))))))

(lookup-in-table 'fish
		 (extend-table '((teach a man to fish)
				 (1 2 3 4 5))
			       (quote ()))
		 (lambda (x) x))

(define atom-to-action
  (lambda (e)
    (cond
     ((number? e) *const)
     ((eq? e #t) *const)
     ((eq? e #f) *const)
     ((eq? e (quote cons)) *const)
     ((eq? e (quote car)) *const)
     ((eq? e (quote cdr)) *const)
     ((eq? e (quote null?)) *const)
     ((eq? e (quote eq?)) *const)
     ((eq? e (quote atom?)) *const)
     ((eq? e (quote zero?)) *const)
     ((eq? e (quote add1)) *const)
     ((eq? e (quote sub1)) *const)
     ((eq? e (quote number?)) *const)
     (else *identifier))))

(atom-to-action 'number?); *const

(define list-to-action
  (lambda (e)
    (cond
     ((atom? (car e)) (cond
		       ((eq? (car e) (quote quote)) *quote)
		       ((eq? (car e) (quote lambda)) *lambda)
		       ((eq? (car e) (quote cond)) *cond)
		       (else *application)))
     (else *application))))

(list-to-action '(lambda (x) x)) ; *lambda
(list-to-action '(cond ((eq? 1 2) #f) (else #t))) ; *cond

(define expression-to-action
  (lambda (e)
    (cond
     ((atom? e) (atom-to-action e))
     (else (list-to-action e)))))

(expression-to-action '#f) ; *const
(expression-to-action '(lambda (x) x)) ; *lambda

(define value
  (lambda (e)
    (meaning e (quote ()))))

(define meaning
  (lambda (e table)
    ((expression-to-action e) e table)))

(define *const
  (lambda (e table)
    (cond
     ((number? e) e)
     ((eq? e #t) #t)
     ((eq? e #f) #f)
     (else (build (quote primitive) e)))))

(*const 'asdf '()) ; (primitive asdf)

(define *quote
  (lambda (e table)
    (text-of e)))

(define text-of second)

(*quote '(quote stuff) '()) ; stuff

(define *identifier
  (lambda (e table)
    (lookup-in-table e table initial-table)))

; this will pass an error if called
(define initial-table
  (lambda (name)
    (car (quote ()))))

;(*identifier 'asdf '()) ; error
(*identifier 'a '( ((1 2 3 a b c) (first second third 1 2 3)))) ; 1

(define *lambda
  (lambda (e table)
    (build (quote non-primitive) (cons table (cdr e)))))

(*lambda '(lambda (a b) (cond ((eq? a b) b) (else a))) '( ((1 2 3) (a b c))))

(meaning '(lambda (x) (cons x y)) '(((y z) ((8) 9))))
; (non-primative ((((y z) ((8) 9)))) (x) (cons x y))

(define table-of first)
(define formals-of second)
(define body-of third)
(third '(a b c)) ; c

(define evcon
  (lambda (lines table)
    (cond
     ((else? (question-of (car lines)))
      (meaning (answer-of (car lines)) table))
     ((meaning (question-of (car lines)) table)
      (meaning (answer-of (car lines)) table))
     (else (evcon (cdr lines) table)))))

(define else?
  (lambda (x)
    (cond
     ((atom? x) (eq? x (quote else)))
     (else #f))))

(define question-of first)
(define answer-of second)

(define *cond
  (lambda (e table)
    (evcon (cond-lines-of e) table)))

(define cond-lines-of cdr)

(define evlis
  (lambda (args table)
    (cond
     ((null? args) (quote ()))
     (else (cons (meaning (car args) table)
		 (evlis (cdr args) table))))))

(evlis '(cons #f 4) '()) ; ((primitive cons) #f 4)

(define function-of car)
(define arguments-of cdr)

(define *application
  (lambda (e table)
    (apply
     (meaning (function-of e) table)
     (evlis (arguments-of e) table))))

(define primitive?
  (lambda (l)
    (eq? (first l) (quote primitive))))

(define non-primitive?
  (lambda (l)
    (eq? (first l) (quote non-primitive))))

(define apply
  (lambda (fun vals)
    (cond
     ((primitive? fun) (apply-primitive (second fun) vals))
     ((non-primitive? fun) (apply-closure (second fun) vals)))))

(define apply-primitive
  (lambda (name vals)
    (cond
     ((eq? name (quote cons)) (cons (first vals) (second vals)))
     ((eq? name (quote car)) (car (first vals)))
     ((eq? name (quote cdr)) (cdr (first vals)))
     ((eq? name (quote null?)) (null? (first vals)))
     ((eq? name (quote eq?)) (eq? (first vals) (second vals)))
     ((eq? name (quote atom?)) (:atom? (first vals)))
     ((eq? name (quote zero?)) (zero? (first vals)))
     ((eq? name (quote add1)) (add1 (first vals)))
     ((eq? name (quote sub1)) (sub1 (first vals)))
     ((eq? name (quote number?)) (number? (first vals))))))

(first '(a b))
(apply-primitive 'null? '(())) ; #t
(*application '(null? 2) '()) ; #f
(*application '(cdr (quote (a b))) '()) ; (b)
(*application '(eq? 2 (add1 1)) '()) ; #t

(define :atom?
  (lambda (x)
    (cond
     ((atom? x) #t)
     ((null? x) #f)
     ((eq? (car x) (quote primitive)) #t)
     ((eq? (car x) (quote non-primitive)) #t)
     (else #f))))

(define apply-closure
  (lambda (closure vals)
    (meaning (body-of closure)
	     (extend-table (new-entry (formals-of closure) vals)
			   (table-of closure)))))

(value '(zero? 0))
(value '(eq? 1 1))
(value '#f) ; #f
(value '(eq? 2 (add1 1))) ; #t

(value '((lambda (a b) (a (add1 b))) (lambda (c) (add1 c)) 4)) ; 6

(value '((lambda (x) x) 1)) ; 1

;wheeee!