path: root/other/seasoned_schemer.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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 foody (quote nothing))


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

(glutton 'garlic)