;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Play-along log to The Seasoned 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 ()))

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

(add1 6) ; 7

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

(sub1 7) ; 6

; kind of guessing here
(define Y
  (lambda (thing)
    ((lambda (le)
       ((lambda (f) (f f))
	(lambda (f) (le (lambda (x) ((f f) x))))))
     thing)))

(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 (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? '(((this) is (a)) nontrivial (list))
	 '(((this) is (a)) nontrivial (list))) ; #t

; needed in not-mechanics
(define one?
  (lambda (x)
    (zero? (sub1 x))))

(one? 2) ; #f
(one? 1) ; #t

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 01: Welsome Back to the Show

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

(member? 'a '(1 2 a b c)) ; #t

(define two-in-a-row?
  (lambda (lat)
    (cond
     ((null? lat) #f)
     (else (is-first-b? (car lat) (cdr lat))))))

(define is-first-b?
  (lambda (a lat)
    (cond
     ((null? lat) #f)
     (else (or (eq? a (car lat)) (two-in-a-row? lat))))))

(is-first-b? 'a '(a b)) ; #t
(two-in-a-row? '(this sentance doesn't have that)) ; #f
(two-in-a-row? '(but this one does right right right)) ; #t

(define two-in-a-row-b?
  (lambda (a lat)
    (cond
     ((null? lat) #f)
     (else (or (eq? a (car lat)) (two-in-a-row-b? (car lat) (cdr lat)))))))

(define two-in-a-row?
  (lambda (lat)
    (cond
     ((null? lat) #f)
     (else (two-in-a-row-b? (car lat) (cdr lat))))))

(define sum-of-prefixes-b
  (lambda (sonssf tup)
    (cond
     ((null? tup) (quote ()))
     (else (cons (+ sonssf (car tup))
		 (sum-of-prefixes-b (+ sonssf (car tup)) (cdr tup)))))))

(define sum-of-prefixes
  (lambda (tup)
    (sum-of-prefixes-b 0 tup)))

(sum-of-prefixes '(1 1 1 1)) ; (1 2 3 4)

;;; {{ The Eleventh Commandment }}
;;; Use additional arguments when a function needs to know what other 
;;; arguments to the function have been like so far.

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

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

(define scramble-b
  (lambda (tup rev-pre)
    (cond
     ((null? tup) (quote ()))
     (else
      (cons (pick (car tup) (cons (car tup) rev-pre))
	    (scramble-b (cdr tup) (cons (car tup) rev-pre)))))))

(define scramble
  (lambda (tup)
    (scramble-b tup (quote ()))))

(scramble '(1 1 1 3 4 2 1 1 9 2)) ; (1 1 1 1 1 4 1 1 1 9)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 12: Take Cover

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

(multirember 'pie '(apple pie other pie what kind of pi?))

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

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

; {{ The Twelfth Commandment }}
; Use (letrec ..) to remove arguments that do not change for 
; recursive applications.

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

(define rember-eq? (rember-f eq?))

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

(define member?
  (lambda (a lat)
    (letrec
	((yes? (lambda (l)
		 (cond
		  ((null? l) #f)
		  ((eq? (car l) a) #t)
		  (else (yes? (cdr l)))))))
      (yes? lat))))

(member? 'a '(1 2 3 a b)) ; #t
(member? 'a '(1 2 3 b)) ; #f

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

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

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

; if member? had the order of its parameters swapped union would no longer work

(define union
  (lambda (a b)
    (letrec
	((U (lambda (s)
	      (cond
	       ((null? s) b)
	       ((member? (car s) b) (U (cdr s)))
	       (else (cons (car s) (U (cdr s)))))))
	 (member? (lambda (a lat)
		    (cond
		     ((null? lat) #f)
		     ((eq? a (car lat)) #t)
		     (else (member? a (cdr lat)))))))
      (U a))))

; {{ The Thirteenth Commandment }}
; Use (letrec ...) to hide and protect functions.

(define union
  (lambda (a b)
    (letrec
	((U (lambda (s)
	      (cond
	       ((null? s) b)
	       ((M? (car s) b) (U (cdr s)))
	       (else (cons (car s) (U (cdr s)))))))
	 (M? (lambda (x y)
	       (letrec
		   ((N? (lambda (lat)
			  (cond
			   ((null? lat) #f)
			   ((eq? x (car lat)) #t)
			   (else (member? x (cdr lat)))))))
		 (N? y)))))
      (U a))))

(define two-in-a-row?
  (letrec
      ((W (lambda (a lat)
	    (cond 
	     ((null? lat) #f)
	     (else (or (eq? (car lat) a)
		       (W (car lat)
			  (cdr lat))))))))
    (lambda (lat)
      (cond
       ((null? lat) #f)
       (else (W (car lat) (cdr lat)))))))

(two-in-a-row? '(are there two in a row here)) ; #f
(two-in-a-row? '(what about around around here)) ; #t
(define sum-of-prefixes
  (lambda (tup)
    (letrec
	((B (lambda (sum t)
	      (cond
	       ((null? t) (quote ()))
	       (else (cons (+ (car t) sum) (B (+ (car t) sum) (cdr t))))))))
      (B 0 tup))))

(sum-of-prefixes '(1 1 1 1 1 1)) ; (1 2 3 4 5 6)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 13: Hop, Skip, and Jump

(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 '(1 2 3 4 a s d f) '(1 a b c d)) ; (1 a d)

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

(define intersectall
  (lambda (lset)
    (letrec
	((A (lambda (lset)
	      (cond
	       ((null? (cdr lset)) (car lset))
	       (else (intersect (car lset) (A (cdr lset))))))))
      (cond
       ((null? lset) (quote ()))
       (else (A lset))))))

(intersectall '(() ()))
(intersectall '( (a b c) (a s d f) (nice day for a walk))) ; (a)

; (letcc hop ...) is the same as 
; (call-with-current-continuation (lambda (hop) ...))

(define intersectall
  (lambda (lset)
    (call-with-current-continuation
     (lambda (hop)
       (letrec
	   ((A (lambda (lset)
		 (cond
		  ((null? (car lset)) (hop (quote ())))
		  ((null? (cdr lset)) (car lset))
		  (else (intersect (car lset) (A (cdr lset))))))))
	 (cond
	  ((null? lset) (quote ()))
	  (else (A lset))))))))


;(define intersectall
;  (lambda (lset)
;    (letcc hop
;	   (letrec
;	       ((A (lambda (lset)
;		     (cond
;		      ((null? (car lset)) (hop (quote ())))
;		      ((null? (cdr lset)) (car lset))
;		      (else (intersect (car lset) (A (cdr lset))))))))
;	     (cond
;	      ((null? lset) (quote ()))
;	  (else (A lset)))))))

(intersectall '( (A B C) (A B D) (A B C))) ; (A B)

; letcc ; not found

(define intersectall
  (lambda (lset)
    (call-with-current-continuation
     (lambda (hop)
       (letrec
	   ((A (lambda (lset)
		 (cond
		  ((null? (car lset)) (hop (quote ())))
		  ((null? (cdr lset)) (car lset))
		  (else (intersect (car lset) (A (cdr lset)))))))
	    (I (lambda (a b)
		 (letrec
		     ((J (lambda (set)
			   (cond
			    ((null? set) (quote ()))
			    ((member? (car set) b) (J (cdr set)))
			    (else (cons (car set) (J (cdr set))))))))
		   (cond
		    ((null? b) (hop (quote ())))
		    (else (J a)))))))
	 (cond
	  ((null? lset) (quote ()))
	  (else (A lset))))))))

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

(rember 'k '(captain kangaroo k))

(define rember-up-to-last
  (lambda (a lat)
    (call-with-current-continuation
     (lambda (skip)
       (letrec
	   ((R (lambda (set)
		 (cond
		  ((null? set) (quote ()))
		  ((eq? (car set) a) (skip (R (cdr set))))
		  (else (cons (car set) (R (cdr set))))))))
	 (R lat))))))

(rember-up-to-last 'thing '(wait do we want this thing or that thing last))
; (last)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 14: Let There be Names

(define leftmost
  (lambda (l)
    (cond
     ((atom? (car l)) (car l))
     (else (leftmost (car l))))))

(leftmost '((second level) first level)) ; second

(define leftmost
  (lambda (set)
    (cond
     ((null? set) (quote ()))
     ((atom? (car set)) (car set))
     (else
      (cond 
       ((atom? (leftmost (car set))) (leftmost (car set)))
       (else (leftmost (cdr set))))))))

(leftmost '(((() a) ()))) ; a

(define leftmost
  (lambda (set)
    (cond
     ((null? set) (quote ()))
     ((atom? (car set)) (car set))
     (else
      (let ((thing (leftmost (car set))))
	(cond
	 ((atom? thing) thing)
	 (else (leftmost (cdr set)))))))))

(define rember1*
  (lambda (a l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (cond
		       ((eq? (car l) a) (cdr l))
		       (else (cons (car l) (rember1* a (cdr l))))))
     (else
      (let ((tried (rember1* a (car l))))
	(cond
	 ((eqlist? tried (car l))
	  (cons (car l) (rember1* a (cdr l))))
	 (else (cons tried (cdr l)))))))))

(rember1* 'meat '((pasta meat) pasta (noodles meat sauce) meat tomatoes))
; ((pasta) pasta (noodles meat sauce) meat tomatoes)

(define depth*
  (lambda (l)
    (cond
     ((null? l) 1)
     ((atom? (car l)) (depth* (cdr l)))
     (else 
      (let 
	  ((down (add1 (depth* (car l))))
	   (across (depth* (cdr l))))
	(cond
	 ((> down across) down)
	 (else across)))))))

(> 1 2) ; #f
(depth* '(c (b (a b) a) a)) ; 3

; this version is redundant!
(define depth*
  (lambda (l)
    (cond
     ((null? l) 1)
     (else
      (let 
	  ((across (depth* (cdr l))))
	(cond 
	 ((atom? (car l)) across)
	 (else 
	  (let
	      ((down (add1 (depth* (car l)))))
	    (cond
	     ((> down across) down)
	     (else across))))))))))

(max 1 4) ; 4

; {{ The Fifteenth Commandment }}
; Use (let ...) to name the values of repeated expressions in a function
; definition if they may be evaluated twice for one and same use of the
; function. And use (let ...) to name the values of expressions (without
; set!) that are re-evaluated every time a function is used.

(define depth*
  (lambda (l)
    (cond
     ((null? l) 1)
     ((atom? (car l)) (depth* (cdr l)))
     (else (max
	    (add1 (depth* (car l)))
	    (depth* (cdr l)))))))

(depth* '(a (b (c d) (e (f g) 4) 4) 4 2 1)) ; 4

(define leftmost
  (lambda (l)
    (call-with-current-continuation
     (lambda (skip)
       (lm l skip)))))

(define lm
  (lambda (l out)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (out (car l)))
     (else (let ()
	     (lm (car l) out)
	     (lm (cdr l) out))))))

(leftmost '((() a) (b c))) ; a

; could also use a (begin (...) (...) ...) statement instead of
; (let () (...) (...) ...)

(define leftmost
  (lambda (l)
    (call-with-current-continuation
     (lambda (out)
       (letrec ((L (lambda (l)
		     (cond
		      ((null? l) (quote ()))
		      ((atom? (car l)) (out (car l)))
		      (else (let ()
			      (L (car l))
			      (L (cdr l))))))))
	 (L l))))))

; try is undefined

;(define rember1*
;  (lambda (a l)
;    (try oh (rm a l oh) l)))

(define rember1*
  (lambda (a l)
    (call-with-current-continuation
     (lambda (success)
       (begin
	 (call-with-current-continuation
	  (lambda (oh)
	    (success (rm a l oh))))
	 l)))))

(define rm
  (lambda (a l oh)
    (cond
     ((null? l) (oh (quote no)))
     ((atom? (car l)) (if (eq? (car l) a)
			  (cdr l)
			  (cons (car l) (rm a (cdr l) oh))))
     (else
      (call-with-current-continuation
       (lambda (success)
	 (begin
	   (call-with-current-continuation
	    (lambda (oh2)
	      (success (cons (rm a (car l) oh2) (cdr l)))))
	   (cons (car l) (rm a (cdr l) oh)))))))))

(rember1* 'green '(jolly green giant)) ; (jolly giant)
(rember1* 'blue '(((is the) (sky)) (ever so (blue da)))) ; good

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 15: The Difference Between Men and Boys...

(define x-thing (cons 'chicago (cons 'pizza '())))

(set! x-thing 'gone) ; returns (chicago pizza)
(set! x-thing 'skins)

(set! x-thing 'rings)

(define gourmand
  (lambda (food)
    (set! x-thing food)
    (cons food
	  (cons x-thing (quote ())))))

(gourmand 'potato)

(define omnivore
  (let ((x-thing (quote soup)))
    (lambda (food)
      (set! x-thing food)
      (cons food (cons x-thing '())))))

(omnivore 'bread)
x-thing ; potato

; {{ The Sixteenth Commandment }}
; Use (set! ...) only with names define in (let ...)s

; {{ The Seventeenth Commandment }}
; Use (set! x ...) for (let ((x ..)) ..)) only if there is at least one
; (lambda .. between it and the (let ..), or if the new value for x is a 
; function that refers to x.

(define nibbler
  (lambda (food)
    (let ((x-thing (quote donut)))
      (set! x-thing food)
      (cons food
	    (cons x-thing '())))))

(nibbler 'boat)
x-thing ; not boat

(define food (quote nothing))

(define glutton
  (lambda (x-thing)
    (set! food x-thing)
    (cons (quote more)
	  (cons x-thing
		(cons (quote more) (cons x-thing (quote ())))))))

(glutton 'garlic); (more garlic more garlic)

(define chez-nous
  (lambda ()
    (let ((a food))
      (set! food x-thing)
      (set! x-thing a))))

food  ; garlic
x-thing  ; potato
(chez-nous)
food  ; potato
x-thing  ; garlic

; {{ The Eighteenth Commandment }}
; Use (set! x ...) only when the value that x refers to is no longer needed.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 16: Ready, Set, Bang!

(define sweet-tooth
  (lambda (food)
    (cons food (cons (quote cake) (quote ())))))

(define last (quote angelfood))

(sweet-tooth last) ; (angelfood cake)

(define sweet-toothL
  (lambda (food)
    (set! last food)
    (cons food (cons (quote cake) (quote ())))))

(sweet-toothL (quote chocolate)) ; (chocolate cake)
last ; chocolate

(define ingredients (quote ()))
(define sweet-toothR
  (lambda (food)
    (set! ingredients (cons food ingredients))
    (cons food (cons (quote cake) (quote ())))))

(sweet-toothR 'chocolate)
(sweet-toothR 'fruit)
(sweet-toothR 'cheese)
ingredients ; (cheese fruit chocolate)

(define deep
  (lambda (m)
    (cond 
     ((zero? m) (quote pizza))
     (else (cons (deep (sub1 m)) (quote ()))))))

(deep 4) ; ((((pizza))))

(define Rs (quote ()))
(define Ns (quote ()))

(define deepR
  (lambda (n)
    (let ((result (deep n)))
      (set! Ns (cons n Ns))
      (set! Rs (cons result Rs))
      result)))

(deepR 4)
(deepR 1)
(deepR 2)
Rs
Ns ; (2 1 4)

; {{ The Nineteenth Commandment }}
; Use (set! ...) to remember valuable things between two distinct uses of a 
; function.

(define find
  (lambda (n Ns Rs)
    (letrec
	((A (lambda (ns rs)
	      (cond
	       ((= (car ns) n) (car rs))
	       (else (A (cdr ns) (cdr rs)))))))
      (A Ns Rs))))

(find 4 Ns Rs)

(define deepM
  (lambda (n)
    (if (member? n Ns)
	(find n Ns Rs)
	(deepR n))))

(deepM 4) ; ((((pizza))))
(deepM 5) ; (((((pizza)))))
Ns ; (5 2 1 4)

(define deepM
  (lambda (n)
    (if (member? n Ns)
	(find n Ns Rs)
	(let ((result (deep n)))
	  (set! Rs (cons result Rs))
	  (set! Ns (cons n Ns))
	  result))))

(deepM 9) 
Ns ; (9 5 2 1 4)

(define deep
  (lambda (m)
    (cond
     ((zero? m) (quote pizza))
     (else (cons (deepM (sub1 m)) (quote ()))))))

(deepM 12)
Ns ; (12 11 10 9 5 2 1 4)

(define deepM
  (let ((Rs (quote ()))
	(Ns (quote ())))
    (lambda (n)
      (if (member? n Ns)
	  (find n Ns Rs)
	  (let ((result (deep n)))
	    (set! Rs (cons result Rs))
	    (set! Ns (cons n Ns))
	    result)))))

(deepM 16)

(define find
  (lambda (n Ns Rs)
    (letrec
	((A (lambda (ns rs)
	      (cond
	       ((null? ns) #f)
	       ((= (car ns) n) (car rs))
	       (else (A (cdr ns) (cdr rs)))))))
      (A Ns Rs))))

(define deepM
  (let ((Rs (quote ()))
	(Ns (quote ())))
    (lambda (n)
	   (let ((exists (find n Ns Rs)))
	     (if (atom? exists)
		 (let ((result (deep n)))
		   (set! Rs (cons result Rs))
		   (set! Ns (cons n Ns))
		   result)
		 exits)))))

(deepM 15)

(length '(a b c d))

(define length
  (let ((h (lambda (l) 0)))
    (set! h
	  (lambda (l)
	    (cond
	     ((null? l) 0)
	     (else (add1 (h (cdr l)))))))
    h))

(define L
  (lambda (length)
    (lambda (l)
      (cond
       ((null? l) 0)
       (else (add1 (length (cdr l))))))))

(define length
  (let ((h (lambda (l) 0)))
    (set! h (L (lambda (arg) (h arg))))
    h))

(length '(1 2 3)) ; 3

(define Y-bang
  (lambda (f)
    (letrec
	((h (f (lambda (arg) (h arg)))))
      h)))

(define length (Y-bang L))

; Y-bang is the "applicative-order imperative Y combinator."

(define D
  (lambda (depth*)
    (lambda (s)
      (cond
       ((null? s) 1)
       ((atom? (car s)) (depth* (cdr s)))
       (else
	(max
	 (add1 (depth* (car s)))
	 (depth* (cdr s))))))))

(define depth* (Y-bang D))

(depth* '(((asdf d)) (d (a)))) ; 3

(define bizarre
  (let ((x 0))
    (lambda (f)
      (set! x (add1 x))
      (lambda (a)
	(if (= a x)
	    0
	    (f a))))))

;((Y-bang bizarre) 3) ; infinite recurse
((Y bizarre) 3) ; 0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 17: We Change, Therefore We Are!

(define deep
  (lambda (m)
    (if (zero? m)
	(quote pizza)
	(cons (deep (sub1 m))
	      (quote ())))))

(define deepM
  (let ((Rs (quote ()))
	(Ns (quote ())))
    (letrec
	((D (lambda (m)
	      (if (zero? m)
		  (quote pizza)
		  (cons (deepM (sub1 m)) (quote ()))))))
      (lambda (n)
	(let ((exists (find n Ns Rs)))
	  (if (atom? exists)
	      (let ((result (D n)))
		(set! Rs (cons result Rs))
		(set! Ns (cons n Ns))
		result)
	      exists))))))

(define deepM
  (let ((Rs (quote ()))
	(Ns (quote ())))
    (lambda (n)
      (let ((exists (find n Ns Rs)))
	(if (atom? exists)
	    (let ((result (if (zero? n)
			      (quote pizza)
			      (cons (deepM (sub1 n)) (quote ())))))
	      (set! Rs (cons result Rs))
	      (set! Ns (cons n Ns))
	      result)
	    exists)))))

(deepM 30) ; good

(define consC
  (let ((N 0))
    (lambda (x y)
      (set! N (add1 N))
      (cons x y))))

; but then can't get the internal N!

(define counter)
(define consC
  (let ((N 0))
    (set! counter (lambda () N))
    (lambda (x y)
      (set! N (add1 N))
      (cons x y))))

(counter) ; 0

(define deep
  (lambda (m)
    (if (zero? m)
	(quote pizza)
	(consC (deep (sub1 m)) (quote ())))))

(deep 5)
(counter) ; 5

(define supercounter
  (lambda (f)
    (letrec
	((S (lambda (n)
	      (if (zero? n)
		  (f n)
		  (let ()
		    (f n)
		    (S (sub1 n)))))))
      (S 1000)
      (counter))))

; takes a long time to run
;(supercounter deep) ; 1233002, b/c I ran with something else first

(define counter)
(define set-counter)
(define consC
  (let ((N 0))
    (set! counter (lambda () N))
    (set! set-counter
	  (lambda (x)
	    (set! N x)))
    (lambda (x y)
      (set! N (add1 N))
      (cons x y))))

(set-counter 0)

; takes a long time to run
;(supercounter deep) ; 500500
(set-counter 0)
(define deepM
  (let ((Rs (quote ()))
	(Ns (quote ())))
    (lambda (n)
      (let ((exists (find n Ns Rs)))
	(if (atom? exists)
	    (let ((result (if (zero? n)
			      (quote pizza)
			      (consC (deepM (sub1 n)) (quote ())))))
	      (set! Rs (cons result Rs))
	      (set! Ns (cons n Ns))
	      result)
	    exists)))))

;this takes a long time to run
;(supercounter deepM) ; 1000

; "A LISP programmer knows the value of everything but the cost of nothing"

;(pp rember1*) ; refers to oh etc


(define rember1*C
  (lambda (a l)
    (letrec
	((R (lambda (l oh)
	      (cond
	       ((null? l) (oh (quote no)))
	       ((atom? (car l)) (if (eq? (car l) a)
				    (cdr l)
				    (consC (car l) (R (cdr l) oh))))
	       (else 
		(let ((new-car
		       (call-with-current-continuation
			(lambda (oh)
			  (R (car l) oh)))))
		  (if (atom? new-car)
		      (consC (car l)
			     (R (cdr l) oh))
		      (consC new-car (cdr l)))))))))
      (let ((new-l (call-with-current-continuation
		    (lambda (oh) (R l oh)))))
	(if (atom? new-l)
	    l
	    new-l)))))

(rember1*C 'noodles '((food) more (food))) ; ((food) more (food))
(rember1*C 'noodles '((food) more (noodles food))) ; ((food) more (food))

(define rember1*C2
  (lambda (a l)
    (letrec
	((R (lambda (l)
	      (cond
	       ((null? l) (quote ()))
	       ((atom? (car l)) (if (eq? (car l) a)
				    (cdr l)
				    (consC (car l) (R (cdr l)))))
	       (else 
		(let ((av (R (car l))))
		  (if (eqlist? (car l) av)
		      (consC (car l) (R (cdr l)))
		      (consC av (cdr l)))))))))
      (R l))))

(set-counter 0)
(rember1*C 'noodles '((food) more (food)))
(counter) ; 0
(rember1*C2 'noodles '((food) more (food)))
(counter) ; 5

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 18: We Change, Therefore We Are the Same!

(cons (quote ()) (quote ())) ; (())

(define kons
  (lambda (kar kdr)
    (lambda (selector)
      (selector kar kdr))))

(define kar
  (lambda (c)
    (c (lambda (a d) a))))

(define kdr
  (lambda (c)
    (c (lambda (a d) d))))

(define bons
  (lambda (kar)
    (let ((kdr (quote ())))
      (lambda (selector)
	(selector
	 (lambda (x) (set! kdr x))
	 kar
	 kdr)))))

(define kar
  (lambda (c)
    (c (lambda (s a d) a))))

(define kdr
  (lambda (c)
    (c (lambda (s a d) d))))

(define kons
  (lambda (a d)
    (let ((c (bons a)))
      (set-kdr c d)
      c)))

(define kounter)
(define set-kounter)
(define konsC
  (let ((N 0))
    (set! kounter (lambda () N))
    (set! set-kounter (lambda (x) (set! N x)))
    (lambda (a b)
      (set! N (add1 N))
      (kons a b))))

(set-kounter 33)
(kounter) ; 33
(set-kounter 0)

(define add-at-end
  (lambda (l)
    (cond
     ((null? (kdr l))
      (konsC (kar l)
	     (kons (quote egg) (quote ()))))
     (else (konsC (kar l)
		  (add-at-end (kdr l)))))))

(add-at-end (lots 3))
(kounter) ; 3

(define add-at-end-too
  (lambda (l)
    (letrec
	((A (lambda (ls)
	      (cond
	       ((null? (kdr ls)) 
		(set-kdr ls (konsC (quote egg) (quote ()))))))))
      (A l)
      l)))

(define set-kdr
  (lambda (c x)
    ((c (lambda (s a d) s)) x)))

(define lots
  (lambda (m)
    (cond
     ((zero? m) (quote ()))
     (else (kons (quote egg)
		 (lots (sub1 m)))))))

(define lenkth
  (lambda (l)
    (cond 
     ((null? l) 0)
     (else (add1 (lenkth (kdr l)))))))

(lots 8) ; [procedure]
(lenkth (lots 9)) ; 9

(set-kounter 0)
(define dozen (lots 12))
(kounter) ; 0

(define bakers-dozen
  (add-at-end dozen))

(kounter) ; 12

(lenkth bakers-dozen) ; 13

(define bakers-dozen-too (add-at-end-too dozen))

(kounter)

(define eklist?
  (lambda (ls1 ls2)
    (cond
     ((null? ls1) (null? ls2))
     ((null? ls2) #f)
     (else (and (eq? (kar ls1) (kar ls2))
		(eklist? (kdr ls1) (kdr ls2)))))))

(define same?
  (lambda (c1 c2)
    (let ((t1 (kdr c1))
	  (t2 (kdr c2)))
      (set-kdr c1 1)
      (set-kdr c2 2)
      (let ((v (= (kdr c1) (kdr c2))))
	(set-kdr c1 t1)
	(set-kdr c2 t2)
	v))))

(same? bakers-dozen bakers-dozen-too) ; #f .... hmmm

(define last-kons
  (lambda (ls)
    (cond
     ((null? (kdr ls)) ls)
     (else (last-kons (kdr ls))))))

(define long (lots 12))

(set-kdr (last-kons long) long)

;(lenkth long) ; haha! looped around!

(define finite-lenkth
  (lambda (p)
    (call-with-current-continuation
     (lambda (infinite)
       (letrec
	   ((C (lambda (p q)
		 (cond
		  ((same? p q) (infinite #f))
		  ((null? q) 0)
		  ((null? (kdr q)) 1)
		  (else (+ (C (sl p) (qk q)) 2)))))
	    (qk (lambda (x) (kdr (kdr x))))
	    (sl (lambda (x) (kdr x))))
	 (cond
	  ((null? p) 0)
	  (else (add1 (C p (kdr p))))))))))

(finite-lenkth long) ; #f yay!


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 19: Absconding with the Jewels

; {{ The Twentieth Commandment }}
; When thinking about a value created with (letcc ...), write down the
; function that is equivalent but does not forget. Then, when you use it,
; remember to forget.

(define deep&co
  (lambda (m k)
    (cond
     ((zero? m) (k (quote pizza)))
     (else
      (deep&co (sub1 m) (lambda (x)
			  (k (cons x (quote ())))))))))

(deep&co 0 (lambda (x) x)) ; pizza
(deep&co 6 (lambda (x) x)) ; ((((((pizza))))))

(define two-layers
  (lambda (p)
    (cons
     (cons p (quote ()))
     (quote ()))))

(define deep&coB
  (lambda (m k)
    (cond
     ((zero? m)
      (let ()
	(set! toppings k)
	(k (quote pizza))))
     (else
      (deep&coB (sub1 m)
		(lambda (x)
		  (k (cons x (quote ())))))))))

(define two-in-a-row?
  (letrec
      ((W (lambda (a lat)
	    (cond
	     ((null? lat) #f)
	     (else
	      (let ((nxt (car lat)))
		(or (eq? nxt a)
		    (W nxt (cdr lat)))))))))
    (lambda (lat)
      (cond ((null? lat) #f)
	    (else (W (car lat) (cdr lat)))))))

; it's not two-in-a-row*?
(two-in-a-row? '(((tomato) paste (tastes)) so (so great))) ; #f 
(two-in-a-row? '(a a)) ; #t

(define leave)

(define walk
  (lambda (l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l)) (leave (car l)))
     (else
      (let ()
	(walk (car l))
	(walk (cdr l)))))))

(define start-it
  (lambda (l)
    (call-with-current-continuation
     (lambda (here)
       (set! leave here)
       (walk l)))))

(define fill)

(define waddle
  (lambda (l)
    (cond
     ((null? l) (quote ()))
     ((atom? (car l))
      (let ()
	(call-with-current-continuation
	 (lambda (rest)
	   (set! fill rest)
	   (leave (car l))))
	(waddle (cdr l)))
      (else (let ()
	      (waddle (car l))
	      (waddle (cdr l))))))))

(define start-it2
  (lambda (l)
    (call-with-current-continuation
     (lambda (here)
       (set! leave here)
       (waddle l)))))

(define get-next
  (lambda (x)
    (call-with-current-continuation
     (lambda (here-again)
       (set! leave here-again)
       (fill (quote go))))))

(define get-first
  (lambda (l)
    (call-with-current-continuation
     (lambda (here)
       (set! leave here)
       (waddle l)
       (leave (quote ()))))))


(start-it2 '((donuts) cheerios (cheerios (spaghettios)) donuts))
(get-first '(a b c d e f g h i)) ; a
(get-first '(a)) ; a
;(get-next (quote go)) ; error... maybe do many defines
(get-first '((fish) and (chips (chips))))
;(get-next 'go)

; i think there might be an error with waddle given
; call-with-current-continuation works... i should try to fix it?

; well, it works below here, so probably just confused above somwhere

(define two-in-a-row*?
  (letrec
      ((T? (lambda (a)
	     (let ((n (get-next 0)))
	       (if (atom? n)
		   (or (eq? n a) (T? n))
		   #f))))
       (get-next (lambda (x)
		   (call-with-current-continuation
		    (lambda (here-again)
		      (set! leave here-again)
		      (fill (quote go))))))
       (fill (lambda (x) x))
       (waddle
	(lambda (l)
	  (cond
	   ((null? l) (quote ()))
	   ((atom? (car l)) (let ()
			      (call-with-current-continuation
			       (lambda (rest)
				 (set! fill rest)
				 (leave (car l))))
			      (waddle (cdr l))))
	   (else (let ()
		   (waddle (car l))
		   (waddle (cdr l)))))))
       (leave (lambda (x) x)))
    (lambda (l)
      (let ((fst (call-with-current-continuation
		  (lambda (here)
		    (set! leave here)
		    (waddle l)
		    (leave (quote ()))))))
	(if (atom? fst) (T? fst) #f)))))

(two-in-a-row*? '(a b c c)) ; #t
(two-in-a-row*? '(((fish) and (chips are) (well) well) what)) ; #t
(two-in-a-row*? '(((fish) and (chips are) (well)) what)) ; #f

; sweet

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Chapter 20: What's in Store?

; lots of definitions, just going to throw them out in whatever order

(define lookup
  (lambda (table name)
    (table name)))

; so if the passed value is equal to our name give our value, otherwise
; pass to next in line
(define extend
  (lambda (name1 value table)
    (lambda (name2)
      (cond
       ((eq? name2 name1) value)
       (else (table name2))))))

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

(define *define
  (lambda (e)
    (set! global-table (extend (name-of e) 
			       (box (The-Meaning (right-side-of e)))
			       global-table))))

(define box
  (lambda (it)
    (lambda (sel)
      (sel it (lambda (new) (set! it new))))))

(define setbox
  (lambda (box new)
    (box (lambda (it set) (set new)))))

(define unbox
  (lambda (box)
    (box (lambda (it set) it))))

(define The-Meaning
  (lambda (e)
    (meaning e lookup-in-global-table)))

(define lookup-in-global-table
  (lambda (name)
    (lookup global-table name)))

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

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

(define *identifier
  (lambda (e table)
    (unbox (lookup table e))))

(define *set
  (lambda (e table)
    (setbox
     (lookup table (name-of e))
     (meaning (right-side-of e) table))))

(define *lambda
  (lambda (e table)
    (lambda (args)
      (beglis (body-of e)
	      (multi-extend (formals-of e) (box-all args) table)))))

(define beglis
  (lambda (es table)
    (cond
     ((null? (cdr es))
      (meaning (car es) table))
     (else ((lambda (val)
	      (beglis (cdr es) table))
	    (meaning (car es) table))))))

(define box-all
  (lambda (vals)
    (cond
     ((null? vals) (quote ()))
     (else (cons (box (car vals))
		 (box-all (cdr vals)))))))

(define multi-extend
  (lambda (names values table)
    (cond
     ((null? names) table)
     (else
      (extend (car names) 
	      (car values)
	      (multi-extend (cdr names) (cdr values) table))))))

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

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

(define :car
  (lambda (args-in-a-list)
    (car (car args-in-a-list))))

(define a-prim
  (lambda (p)
    (lambda (args-in-a-list)
      (p (car args-in-a-list)))))

(define b-prim
  (lambda (p)
    (lambda (args-in-a-list)
      (p (car args-in-a-list) (car (cdr args-in-a-list))))))

(define *const
  (lambda (e table)
    (cond
     ((number? e) e)
     ((eq? e #t) #t)
     ((eq? e #f) #f)
     ((eq? e (quote cons)) (b-prim cons))
     ((eq? e (quote car)) (a-prim car))
     ((eq? e (quote cdr)) (a-prim cdr))
     ((eq? e (quote eq?)) (b-prim eq?))
     ((eq? e (quote atom?)) (a-prim atom?))
     ((eq? e (quote null?)) (a-prim null?))
     ((eq? e (quote zero?)) (a-prim zero?))
     ((eq? e (quote add1)) (a-prim add1))
     ((eq? e (quote sub1)) (a-prim sub1))
     ((eq? e (quote number?)) (a-prim number?)))))

; whew!

; crap, don't want to have to do a-prim/b-prim every time but 
; also avoiding (let ...) for whatever reason

(define *const
  ((lambda (:cons :car :cdr :null? :eq? :atom? :zero? :add1 :sub1 :number?)
     (lambda (e table)
       (cond
	((number? e) e)
	((eq? e #t) #t)
	((eq? e #f) #f)
	((eq? e (quote cons)) :cons)
	((eq? e (quote car)) :car)
	((eq? e (quote cdr)) :cdr)
	((eq? e (quote eq?)) :eq?)
	((eq? e (quote atom?)) :atom?)
	((eq? e (quote null?)) :null?)
	((eq? e (quote zero?)) :zero?)
	((eq? e (quote add1)) :add1)
	((eq? e (quote sub1)) :sub1)
	((eq? e (quote number?)) :number?))))
   (b-prim cons)
   (a-prim car)
   (a-prim cdr)
   (a-prim null?)
   (b-prim eq?)
   (a-prim atom?)
   (a-prim zero?)
   (a-prim add1)
   (a-prim sub1)
   (a-prim number?)))

; double whew!

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

(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 *letcc
  (lambda (e table)
    (call-with-current-continuation
     (lambda (skip)
       (beglis (ccbody-of e) (extend (name-of e)
				     (box (a-prim skip))
				     table))))))

(define abort)
(define value
  (lambda (e)
    (call-with-current-continuation
     (lambda (the-end)
       (set! abort the-end)
       (cond
	((define? e) (*define e))
	(else (The-Meaning e)))))))

; is there any language/interpreter which, when it runs into an undefined
; value, lets you define it on the spot? would be great for learners

(define the-empty-table
  (lambda (name)
    (abort (cons (quote no-answer) (cons name (quote ()))))))

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

(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))))

(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 letcc)) *letcc)
       ((eq? (car e) (quote set!)) *set)
       ((eq? (car e) (quote cond)) *cond)
       (else *application)))
     (else *application))))

;leftovers...
(define text-of
  (lambda (x)
    (car (cdr x))))
(define formals-of
  (lambda (x)
    (car (cdr x))))
(define body-of
  (lambda (x)
    (cdr (cdr x))))
(define ccbody-of
  (lambda (x)
    (cdr (cdr x))))
(define name-of
  (lambda (x)
    (car (cdr x))))
(define right-side-of
  (lambda (x)
    (cond
     ((null? (cdr (cdr x))) 0)
     (else (car (cdr (cdr x)))))))
(define cond-lines-of
  (lambda (x)
    (cdr x)))
(define question-of
  (lambda (x)
    (car x)))
(define answer-of
  (lambda (x)
    (car (cdr x))))
(define function-of
  (lambda (x)
    (car x)))
(define arguments-of
  (lambda (x)
    (cdr x)))

; the right-side-of part is for things like (define stub)
(define global-table the-empty-table)

(value '(value 1))
(value '(add1 4)) ; 5
(value '(define x 7))
(value 'x) ; 7
(value '(define even?
	  (lambda (x)
	    (cond
	     ((zero? x) #t)
	     (else (odd? (sub1 x)))))))
(value '(define odd?
	  (lambda (x)
	    (cond
	     ((zero? x) #f)
	     (else (even? (sub1 x)))))))
(value '(odd? 3)) ; #t
(value '(odd? 32)) ; slow... but #f!

; i'm kind of miffed that the (letcc ...) definition basically just uses
; letcc, because magic North Pole compasses seem like the most interesting 
; part.