The Little Shemer笔记

;;预备函数
(define (atom? x)
  (and (not (pair? x))
       (not (null? x))))
(define (sub1 x)
  (- x 1))
(define (add1 x)
  (+ x 1))
;辅助函数，方便用来显示结果
(define-syntax print
  (syntax-rules ()
    ((_) #f)
    ((_ e) (begin
             (display 'e)
             (display " => ")
             (display e)
             (newline)))
    ((_ e1 e2 e3 ...)
     (begin
       (print e1)
       (print e2 e3 ...)))))
;测试辅助函数，看看效果
(print
 (print
  (print
   (print
    (print
     (print
      (print
       (print (+ 1 2 3)))))))))
;;Begin of Chapter 1
(print
 (atom? 'atom)
 (atom? "atom")
 (atom? "turkey")
 (atom? 1492)
 (atom? #\u)
 (atom? "u")
 (atom? "*abc$")
 (atom? '(atom))
 (atom? '(atom turkey or))
 (atom? atom?)
 (length '(how are you doing so far))
 (atom? '())
 (car '(a b c))
 (car '((a b c) x y z))
 ;;The Law of Car
 ;;The primitive car is defined only for non-empty lists.
 (car '(((hotdogs)) (and) (pickle) relish))
 (car (car '(((hotdogs)) (and) (pickle) relish)))
 (cdr '(a b c))
 (cdr '((a b c) x y z))
 (cdr '(hamburger))
 (cdr '((x) t r))
 (cdr '(((hotdogs)) (and) (pickle) relish))
 ;;The Law of Cdr
 ;;The primitive cdr is defined only for non-empty lists.
 ;;The cdr of any nonempty list is always another list.
 (car (cdr '((b) (x y) ((c)))))
 (cdr (cdr '((b) (x y) ((c)))))
 ;;Car & Cdr takes any non-empty list.
 (cons 'peanut '(butter and jelly))
 (cons '(banana and) '(peanut butter and jelly))
 (cons '(a b c) '())
 (cons 'a '())
 ;;The Law of Cons
 ;;The primitive cons takes two arguments.
 ;;The second argument to cons must be a list.
 ;;The result is a list.
 (cons 'a (car '((b) c d)))
 (cons 'a (cdr '((b) c d)))
 (null? '())
 (null? (quote ()))
 ;;The Law of Null?
 ;;The primitive null ? is defined only for lists.
 (atom? 'Harry)
 (atom? "Harry")
 (eq? 'harry 'harry)
 (eq? 'harry "harry")
 ;;The Law of Eq?
 ;;The primitive eq? takes two arguments.
 ;;Each must be a nonnumeric atom.
 (eq? (car '(beans beans we need jelly beans))
      (car (cdr '(beans beans we need jelly beans)))))
;;End of Chapter 1
;;Begin of Chapter 2
(define (lat? l)
  (cond
    ((null? l) #t)
    ((atom? (car l))
     (lat? (cdr l)))
    (else #f)))
(print
 (lat? '(jack sprat could eat no chicken fat))
 (lat? '((jack) sprat could eat no chicken fat))
 (lat? '(jack (sprat could) eat no chicken fat))
 (lat? '())
 )
(define (member? a lat)
  (cond
    ((null? lat) #f)
    (else (or (equal? (car lat) a)
              (member? a (cdr lat))))))
;;End of Chapter 2
;;Begin of Chapter 3
(define (rember a lat)
  (cond
    ((null? lat) '())
    ((equal? (car lat) a) (cdr lat))
    (else (cons (car lat)
                (rember a (cdr lat))))))
(define (multirember a lat)
  (cond
    ((null? lat) '())
    ((equal? (car lat) a) (multirember a (cdr lat)))
    (else (cons (car lat)
                (multirember a (cdr lat))))))
 
(define (firsts lat)
  (cond
    ((null? lat) '())
    (else (cons (car (car lat)) (firsts (cdr lat))))))
(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))))))
(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))))))
(define (insertL new old lat)
  (cond
    ((null? lat) '())
    ((eq? old (car lat)) (cons new (cons old (cdr lat))))
    (else (cons (car lat) (insertL new old (cdr lat))))))
(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))))))
(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 (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))))))
(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))))))
(print
 (rember 'd '(a b c d e f d h g i m))
 (multirember 'd '(a b c d e f d h g i m))
 (firsts
  '((apple peach p u m pkin)
    (plum pear cherry)
    (grape raisi n pea)
    (bean carrot eggplant)))
 (insertR 'e 'd '(a b c d f g d h))
 (multiinsertR 'e 'd '(a b c d f g d h))
 (insertL 'e 'd '(a b c d f g d h))
 (multiinsertL 'e 'd '(a b c d f g d h))
 (subst 'e 'd '(a b c d f g d h))
 (multisubst 'e 'd '(a b c d f g d h))
 (subst2 'e 'd 'b '(a b c d f g d h)))
;;End of Chapter 3
;;Begin of Chapter 4
;;本章节讨论自然数集
(define (my+ m n)
  (cond
    ((zero? m) n)
    (else (add1 (my+ (sub1 m) n)))))
(define (my- m n)
  (cond
    ((zero? n) m)
    (else (sub1 (my- m (sub1 n))))))
(define (tup? lat)
  (cond
    ((null? lat) #t)
    ((number? (car lat)) (tup? (cdr lat)))
    (else #f)))
(define (addtup tup)
  (cond
    ((null? tup) 0)
    (else (my+ (car tup) (addtup (cdr tup))))))
(define (my* m n)
  (cond
    ((zero? n) 0)
    (else (my+ m (my* m (sub1 n))))))
(define (tup+ t1 t2)
  (cond
    ((null? t1) t2)
    ((null? t2) t1)
    (else (cons
           (my+ (car t1) (car t2))
           (tup+ (cdr t1) (cdr t2))))))
(define (my> m n)
  (cond
    ((zero? m) #f)
    ((zero? n) #t)
    (else (my> (sub1 m) (sub1 n)))))
(define (my< m n)
  (cond
    ((zero? n) #f)
    ((zero? m) #t)
    (else (my< (sub1 m) (sub1 n)))))
(define (my= m n)
  (cond
    ((and (zero? m) (zero? n)) #t)
    ((or (zero? m) (zero? n)) #f)
    (else (my= (sub1 m) (sub1 n)))))
(define (my^ m n)
  (cond
    ((zero? n) 1)
    (else (my* m (my^ m (sub1 n))))))
(define (my/ m n)
  (cond
    ((my< m n) 0)
    (else (add1 (my/ (my- m n) n)))))
(define (my-length lat)
  (cond
    ((null? lat) 0)
    (else (add1 (my-length (cdr lat))))))
(define (pick n lat)
  (if (zero? (sub1 n))
      (if (null? lat) #f (car lat))
      (pick (sub1 n) (cdr lat))))
(define (no-nums lat)
  (cond
    ((null? lat) '())
    ((number? (car lat)) (no-nums (cdr lat)))
    (else (cons (car lat) (no-nums (cdr lat))))))
(define (all-nums lat)
  (cond
    ((null? lat) '())
    ((number? (car lat)) (cons (car lat) (all-nums (cdr lat))))
    (else (all-nums (cdr lat)))))
(define (eqan? a1 a2)
  (cond
    ((and (number? a1) (number? a2))
     (my= a1 a2))
    ((or (number? a1) (number? a2))
     #f)
    (else (eq? a1 a2))))
(define (occur a lat)
  (cond
    ((null? lat) 0)
    ((eqan? a (car lat))
     (add1 (occur a (cdr lat))))
    (else (occur a (cdr lat)))))
(define (one? n)
  (my= n 1))
(define (rempick n lat)
  (cond
    ((one? n) (cdr lat))
    (else (cons (car lat) (rempick (sub1 n) (cdr lat))))))
(print
 (atom? 3.1415926)
 (number? 3.1415926)
 (add1 67)
 (sub1 5)
 (zero? 0)
 (zero? 1492)
 (my+ 46 12)
 (my- 46 12)
 (tup? '(1 2 3 4 5 667 23 23))
 (tup? '(1 2 3 4 (5 667) 23 23))
 (tup? '(1 2 3 4 a 667 b 23))
 (addtup '(1 2 3 4 5 6 7 8 9))
 (addtup '(15 6 7 12 3))
 (my* 3 5)
 (my* 33 55)
 (tup+ '(3 6 9 11 4) '(8 5 2 0 7))
 (tup+ '(3 6 9) '(8 5 2 0 7))
 (my> 1 2)
 (my> 1 1)
 (my> 2 1)
 (my< 1 2)
 (my< 1 1)
 (my< 2 1)
 (my= 1 2)
 (my= 1 1)
 (my= 2 1)
 (my^ 2 3)
 (my^ 2 11)
 (my^ 3 11)
 (my/ 11 2)
 (my/ 11 3)
 (my/ 11 4)
 (my/ 11 5)
 (my/ 11 12)
 (my-length '(1 2 3 4 5 6 7 8 9 a b c d e f g))
 (pick 3 '(1 2 3 4 5 6 7 8 9 a b c d e f g))
 (pick 11 '(1 2 3 4 5 6 7 8 9 a b c d e f g))
 (no-nums '(1 2 3 4 5 6 7 8 9 a b c d e f g))
 (no-nums '(1 a 2 v 3 4 s 5 6 a 7 8 9 a b c d e f g))
 (all-nums '(1 2 3 4 5 6 7 8 9 a b c d e f g))
 (all-nums '(1 a 2 v 3 4 s 5 6 a 7 8 9 a b c d e f g))
 (eqan? 'a 'b)
 (eqan? 'a 'a)
 (eqan? 'a 2)
 (eqan? 1 2)
 (eqan? 2 2)
 (occur 2 '(1 a 2 b 3 c 2 d c 4 n c m 2 5 2 r c y 6 2 7 2 8 9))
 (occur 'c '(1 a 2 b 3 c 2 d c 4 n c m 2 5 2 r c y 6 2 7 2 8 9))
 (one? 1)
 (one? 0)
 (one? 2)
 (rempick 6 '(1 a 2 b 3 c)))
;;End of Chapter 4
;;Begin of Chapter 5
(define (rember* a lat)
  (cond
    ((null? lat) '())
    ((pair? (car lat))
     (cons (rember* a (car lat))
           (rember* a (cdr lat))))
    ((eq? a (car lat))
     (rember* a (cdr lat)))
    (else (cons (car lat) (rember* a (cdr lat))))))
(define (insertR* new old lat)
  (cond
    ((null? lat) '())
    ((pair? (car lat))
     (cons (insertR* new old (car lat))
           (insertR* new old (cdr lat))))
    ((eq? old (car lat))
     (cons old (cons new (insertR* new old (cdr lat)))))
    (else (cons (car lat) (insertR* new old (cdr lat))))))
(define (occur* a lat)
  (cond
    ((null? lat) 0)
    ((pair? (car lat))
     (my+ (occur* a (car lat))
          (occur* a (cdr lat))))
    ((eq? a (car lat))
     (add1 (occur* a (cdr lat))))
    (else (occur* a (cdr lat)))))
(define (subst* new old lat)
  (cond
    ((null? lat) '())
    ((pair? (car lat))
     (cons (subst* new old (car lat))
           (subst* new old (cdr lat))))
    ((eq? old (car lat))
     (cons new (subst* new old (cdr lat))))
    (else (cons (car lat) (subst* new old (cdr lat))))))
(define (insertL* new old lat)
  (cond
    ((null? lat) '())
    ((pair? (car lat))
     (cons (insertL* new old (car lat))
           (insertL* new old (cdr lat))))
    ((eq? old (car lat))
     (cons new (cons old (insertL* new old (cdr lat)))))
    (else (cons (car lat) (insertL* new old (cdr lat))))))
(define (member*? a lat)
  (cond
    ((null? lat) #f)
    ((pair? (car lat))
     (or (member*? a (car lat))
         (member*? a (cdr lat))))
    ((eq? a (car lat)) #t)
    (else (member*? a (cdr lat)))))
(define (leftmost lat)
  (cond
    ((atom? (car lat)) (car lat))
    (else (leftmost (car lat)))))
(define (eqlist? l1 l2)
  (cond
    ((and (atom? l1) (atom? l2)) (eq? l1 l2))
    ((or (atom? l1) (atom? l2)) #f)
    ((and (null? l1) (null? l1)) #t)
    ((or (null? l1) (null? l1)) #f)
    (else (and (eqlist? (car l1) (car l2))
               (eqlist? (cdr l1) (cdr l2))))))
(define (my-equal? s1 s2)
  (cond
    ((and (atom? s1) (atom? s2))
     (eqan? s1 s2))
    ((or (atom? s1) (atom? s2)) #f)
    (else (eqlist? s1 s2))))
;;重写eqlist?，假设参数一定是list
(define (eqlist? l1 l2)
  (cond
    ((and (null? l1) (null? l1)) #t)
    ((or (null? l1) (null? l1)) #f)
    (else (and (my-equal? (car l1) (car l2))
               (eqlist? (cdr l1) (cdr l2))))))
(print
 (rember* 'cup '((coffee) cup ((tea) cup) (and (hick)) cup))
 (rember* 'sauce '(((tomato sauce))
                   ((bean) sauce)
                   (and ((flying)) sauce)))
 (insertR* 'roast 'chuck '((how much (wood))
                           could
                           ((a (wood) chuck))
                           (((chuck)))
                           (if (a) ((wood chuck)))
                           could chuck wood))
 (occur* 'banana '((banana)
                   (split ((((banana ice)))
                           (cream (banana))
                           sherbet))
                   (banana)
                   (bread)
                   (banana brandy)))
 (subst* 'xxx 'banana '((banana)
                        (split ((((banana ice)))
                                (cream (banana))
                                sherbet))
                        (banana)
                        (bread)
                        (banana brandy)))
 (insertL* 'roast 'chuck '((how much (wood))
                           could
                           ((a (wood) chuck))
                           (((chuck)))
                           (if (a) ((wood chuck)))
                           could chuck wood))
 (member*? 'chips '((potato) (chips ((with) fish) (chips))))
 (leftmost '((potato) (chips ((with) fish) (chips))))
 (leftmost '(((hot) (tuna (and))) cheese))
 ;;(leftmost '(((() four)) 17 (seventeen)))
 (eqlist? '(1 2 3 4 5) '(1 2 3 4 a))
 (eqlist? '(1 2 3 4 (b c d (k l m) e f g) 5) '(1 2 3 4 (b c d (k l m) e f g) 5))
 (eqlist? '(1 2 3 4 (b c d (k l m) e f g) 5) '(1 2 3 4 (b c d (k 1 m) e f g) 5))
 (my-equal? '(1 2 3 4 (b c d (k l m) e f g) 5) '(1 2 3 4 (b c d (k 1 m) e f g) 5))
 (equal? '(1 2 3 4 (b c d (k l m) e f g) 5) '(1 2 3 4 (b c d (k 1 m) e f g) 5)))
 
;;End of Chapter 5
;;Begin of Chapter 6
(define (op-num? a)
  (or (number? a) (eq? a '+) (eq? a '+) (eq? a '*) (eq? a 'x) (eq? a 'my^)))
(define (my-numbered? lat)
  (cond
    ((atom? lat) (op-num? lat))
    ((null? lat) #t)
    (else (and (my-numbered? (car lat)) (my-numbered? (cdr lat))))))
;; my-numbered? 不能判断语法结构是否正确
(define (op? a)
  (or (eq? a '+) (eq? a '+) (eq? a '*) (eq? a 'x) (eq? a 'my^)))
(define (numbered? lat)
  (cond
    ((atom? lat) (number? lat))
    ((and (= 3 (length lat)) (op? (car (cdr lat)))) (and (numbered? (car lat)) (numbered? (car (cdr (cdr lat))))))
    (else #f)))
 
(define (value nexp)
  (cond
    ((atom? nexp) nexp)
    ((eq? '+ (car (cdr nexp))) (my+ (value (car nexp)) (value (car (cdr (cdr nexp))))))
    ((eq? 'x (car (cdr nexp))) (my* (value (car nexp)) (value (car (cdr (cdr nexp))))))
    ((eq? 'my^ (car (cdr nexp))) (my^ (value (car nexp)) (value (car (cdr (cdr nexp))))))
    (else "value error")))
;; numbered? 检查语法规则符合
;; express -> NUMBER | express op express | (express)
;; op -> + x my^
(define (1st-sub-exp aexp)
  (car aexp))
(define (2nd-sub-exp aexp)
  (car (cdr (cdr aexp))))
(define (operator nexp)
  (car (cdr nexp)))
(define (value nexp)
  (cond
    ((atom? nexp) nexp)
    ((eq? '+ (operator nexp)) (my+ (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp))))
    ((eq? 'x (operator nexp)) (my* (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp))))
    ((eq? 'my^ (operator nexp)) (my^ (value (1st-sub-exp nexp)) (value (2nd-sub-exp nexp))))
    (else "value error2")))
 
(print
 (my-numbered? 1)
 (my-numbered? '(3 + 4 x 5))
 (my-numbered? '(2 x x x))
 (my-numbered? '(3 + (4 my^ 5)))
 (numbered? 1)
 (numbered? '(3 + 4 x 5))
 (numbered? '(2 x 2 x 3))
 (numbered? '(3 + (4 my^ 5)))
 (numbered? '(3 + 4 4 x 5))
 (numbered? '(2 x x 2 x 3))
 (numbered? '(3 + (4 my^ my^ 5)))
 (value '(3 + (4 my^ 5)))
 (value '(3 + ((4 x 3) my^ 5)))
 (value '(() () () ())))
 
(define (sumber? n)
  (cond
    ((atom? n) #f)
    ((null? n) #t)
    (else (and (sumber? (car n)) (sumber? (cdr n))))))
(define (slat? ls)
  (cond
    ((null? ls) #t)
    (else (and (sumber? (car ls)) (slat? (cdr ls))))))
(define (sero? n)
  (null? n))
(define (edd1 n)
  (cons '() n))
(define (zub1 n)
  (cdr n))
(define (s+ n1 n2)
  (cond
    ((sero? n2) n1)
    (else (s+ (edd1 n1) (zub1 n2)))))
(print
 (sero? '())
 (sero? '(()))
 (sero? '(() ()))
 (edd1 '())
 (edd1 (edd1 '()))
 (sumber? '())
 (sumber? '(()))
 (sumber? '(() ()))
 (sumber? (edd1 '()))
 (sumber? (edd1 (edd1 '())))
 (sumber? '(1))
 (sumber? '((1)))
 (sumber? '(() (1)))
 (sumber? (edd1 '(1)))
 (sumber? (edd1 (edd1 '())))
 (s+ (edd1 '()) (edd1 (edd1 '())))
 (slat? '((()) (() ()) (() () ())))
 (slat? '((()) (() ()) (() () ()))))
;;End of Chapter 6
;;Begin of Chapter 7
(define (set? lat)
  (cond
    ((null? lat) #t)
    ((member? (car lat) (cdr lat)) #f)
    (else (set? (cdr lat)))))
(define (makeset lat)
  (cond
    ((null? lat) '())
    ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
    (else (cons (car lat) (makeset (cdr lat))))))
(define (subset? s1 s2)
  (cond
    ((null? s1) #t)
    ((member? (car s1) s2) (subset? (cdr s1) s2))
    (else #f)))
(define (eqset? s1 s2)
  (and (subset? s1 s2)
       (subset? s2 s1)))
(define (intersect? s1 s2)
  (cond
    ((null? s1) #f)
    (else (or (member? (car s1) s2)
              (intersect? (cdr s1) s2)))))
 
(define (intersect s1 s2)
  (cond
    ((null? s1) '())
    ((member? (car s1) s2) (cons (car s1) (intersect (cdr s1) s2)))
    (else (intersect (cdr s1) s2))))
(define (union s1 s2)
  (cond
    ((null? s1) s2)
    ((member? (car s1) s2) (union (cdr s1) s2))
    (else (cons (car s1) (union (cdr s1) s2)))))
(define (set- s1 s2)
  (cond
    ((null? s1) '())
    ((member? (car s1) s2) (set- (cdr s1) s2))
    (else (cons (car s1) (set- (cdr s1) s2)))))
(define (intersectall l-set)
  (cond
    ((null? l-set) '())
    ((null? (cdr l-set)) (car l-set))
    (else (intersect (car l-set) (intersectall (cdr l-set))))))
(define (makeset2 lat)
  (cond
    ((null? lat) '())
    (else (cons (car lat) (makeset2 (multirember (car lat) (cdr lat)))))))
(define (a-pair? x)
  (cond
    ((or (atom? x) (null? x) (null? (cdr x))) #f)
    ((null? (cdr (cdr x))) #t)
    (else #f)))
(define (first p)
  (car p))
(define (second p)
  (car (cdr p)))
(define (build s1 s2)
  (cons s1 (cons s2 '())))
(define (third p)
  (car (cdr (cdr p))))
(define (rel? l)
  (cond
    ((or (atom? l) (not (set? l))) #f)
    ((null? l) #t)
    ((a-pair? (car l)) (rel? (cdr l)))
    (else #f)))
;;fun映射
(define (fun? rel)
  (set? (firsts rel)))
(define (revpair pair)
  (build (second pair)
         (first pair)))
(define (revrel rel)
  (cond
    ((null? rel) '())
    (else (cons (revpair (car rel))
                (revrel (cdr rel))))))
(define (seconds lat)
  (cond
    ((null? lat) '())
    (else (cons (second (car lat)) (seconds (cdr lat))))))
(define (fullfun? fun)
  (and (fun? fun)
       (set? (seconds fun))))
(define (one-to-one? fun)
  (set? (seconds fun)))
(print
 (set? '(apple peaches apple plum))
 (set? '(apples peaches pears plums))
 (set? '(apple 3 pear 9 3.0 4))
 (makeset '(1 2 3 4 3 4 3 4 5 d d d d d d))
 (makeset '(apple peach pear peach plum apple lemon peach))
 (makeset2 '(1 2 3 4 3 4 3 4 5 d d d d d d))
 (makeset2 '(apple peach pear peach plum apple lemon peach))
 (makeset2 '(apple 3 pear 4 9 apple 3 4))
 (subset? '(5 chicken wings) '(5 hamburgers
                                 2 pieces fried chicken and
                                 light duckling wings))
 (subset? '(4 pounds of horseradish) '(four pounds chicken and
                                            5 ounces horseradish))
 (eqset? '(1 2 3 4 5 6) '(5 3 1 2 4 6))
 (eqset? '(1 2 3 4 5 6) '(5 3 l 2 4 6))
 (intersect? '(1 2 3 a 4 5 6) '(b c d e a f))
 (intersect? '(1 2 3 a 4 5 6) '(b c d e t f))
 (intersect? '(stewed tomatoes and macaroni) '(macaroni and cheese))
 (intersect '(1 2 3 a 4 5 6) '(b c d e a f))
 (intersect '(1 2 3 a 4 5 6) '(b c d e t f))
 (union '(1 2 3 a 4 5 6) '(b c d e a f))
 (union '(1 2 3 a 4 5 6) '(b c d e t f))
 (set? (union '(1 2 3 a 4 5 6) '(b c d e a f)))
 (set? (union '(1 2 3 a 4 5 6) '(b c d e t f)))
 (set- '(1 2 3 4 5 6 7) '(2 3 4))
 (set- '(1 2 3 4 5 6 7) '(2 3 s 4))
 (intersectall '((a b c) (c a d e) (e f g h a b)))
 (intersectall '((6 pears and)
                 (3 peaches and 6 peppers)
                 (8 pears and 6 plums)
                 (and 6 pru nes with some apples)))
 (a-pair? '(pear pear))
 (a-pair? '(3 7))
 (a-pair? '((2) (pair)))
 (a-pair? '(full (house)))
 (build 1 2)
 (set? '((apples peaches)
         (pumpkin pie)
         (apples peaches)))
 (rel? '(apples peaches pumpkin pie))
 (rel? '((apples peaches)
         (pumpkin pie)
         (apples peaches)))
 (rel? '((apples peaches) (pumpkin pie)))
 (rel? '((4 3) (4 2) (7 6) (6 2) (3 4)))
 (firsts '((apples peaches) (pumpkin pie)))
 (firsts '((4 3) (4 2) (7 6) (6 2) (3 4)))
 (fun? '((apples peaches) (pumpkin pie)))
 (fun? '((4 3) (4 2) (7 6) (6 2) (3 4)))
 (revrel '((8 a) (pumpkin pie) (got sick)))
 (revrel (revrel '((8 a) (pumpkin pie) (got sick))))
 (firsts '((8 3) (4 2) (7 6) (6 2) (3 4)))
 (firsts '((8 3) (4 8) (7 6) (6 2) (3 4)))
 (seconds '((8 3) (4 2) (7 6) (6 2) (3 4)))
 (seconds '((8 3) (4 8) (7 6) (6 2) (3 4)))
 (fullfun? '((8 3) (4 2) (7 6) (6 2) (3 4)))
 (fullfun? '((8 3) (4 8) (7 6) (6 2) (3 4))))
;;End of Chapter 7
;;Begin of Chapter 8
(define (rember-f test? a lat)
  (cond
    ((null? lat) '())
    ((test? (car lat) a) (cdr lat))
    (else (cons (car lat)
                (rember-f test? a (cdr lat))))))
 
(define (rember-f test?)
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((test? (car lat) a) (cdr lat))
      (else (cons (car lat)
                  ((rember-f test?) a (cdr lat)))))))
 
(define (seqL new old l)
  (cons new (cons old l)))
(define (insertL-f test?)
  (lambda (new old lat)
    (cond
      ((null? lat) '())
      ((test? (car lat) old) (seqL new old ((insertL-f test?) new old (cdr lat))))
      (else (cons (car lat) ((insertL-f test?) new old (cdr lat)))))))
 
(define (seqR new old l)
  (cons old (cons new l)))
(define (insertR-f test?)
  (lambda (new old lat)
    (cond
      ((null? lat) '())
      ((test? (car lat) old) (seqR new old ((insertR-f test?) new old (cdr lat))))
      (else (cons (car lat) ((insertR-f test?) new old (cdr lat)))))))
 
(define (insert-g seq)
  (lambda (new old lat)
    (cond
      ((null? lat) '())
      ((equal? (car lat) old) (seq new old ((insert-g seq) new old (cdr lat))))
      (else (cons (car lat) ((insert-g seq) new old (cdr lat)))))))
 
(define insertL (insert-g seqL))
(define insertR (insert-g seqR))
 
(define insertL (insert-g (lambda (new old l)
                            (cons new (cons old l)))))
(define insertR (insert-g (lambda (new old l)
                            (cons old (cons new l)))))
(define subst (insert-g (lambda (new old l)
                          (cons new l))))
 
(define rember-eq? (rember-f eq?))
(define rember-equal? (rember-f equal?))
(print
 ((rember-f =) 5 '(6 2 5 3))
 ((rember-f eq?) 'jelly '(jelly beans are good))
 ((rember-f eq?) '(pop corn) '(lemonade (pop corn) and (cake)))
 ((rember-f equal?) '(pop corn) '(lemonade (pop corn) and (cake)))
 
 (rember-eq? '(pop corn) '(lemonade (pop corn) and (cake)))
 (rember-equal? '(pop corn) '(lemonade (pop corn) and (cake)))
 ((insertL-f eq?) 'a 1 '(1 2 3 1 4 5 1 3 5 2 1 1 1 1 2 4 2 4 1 1 1 1 1 1))
 ((insertR-f eq?) 'a 1 '(1 2 3 1 4 5 1 3 5 2 1 1 1 1 2 4 2 4 1 1 1 1 1 1))
 (insertL 'a 1 '(1 2 3 4 1 1 1 d))
 (insertR 'a 1 '(1 2 3 4 1 1 1 d))
 (subst 'a 1 '(1 2 3 4 1 1 1 d)))
(define (atom-to-function x)
  (cond
    ((eq? x '+) my+)
    ((eq? x 'x) my*)
    ((eq? x 'my^) my^)
    (else "atom-to-function error")))
(define (value nexp)
  (cond
    ((atom? nexp) nexp)
    (else ((atom-to-function (car (cdr nexp)))
           (value (car nexp))
           (value (car (cdr (cdr nexp))))))))
(define (multirembercol a lat col)
  (cond
    ((null? lat) (col '() '()))
    ((eq? (car lat) a)
     (multirembercol a (cdr lat)
                     (lambda (newlat seen)
                       (col newlat
                            (cons (car lat) seen)))))
    (else (multirembercol a (cdr lat)
                          (lambda (newlat seen)
                            (col (cons (car lat) newlat)
                                 seen))))))
(define (evens-only* lat)
  (cond
    ((null? lat) '())
    ((pair? (car lat)) (cons (evens-only* (car lat))
                             (evens-only* (cdr lat))))
    ((even? (car lat)) (cons (car lat)
                             (evens-only* (cdr lat))))
    (else (evens-only* (cdr lat)))))
(define (evens-only*&co lat col)
  (cond
    ((null? lat) (col '() 1 0))
    ((pair? (car lat)) (evens-only*&co (car lat)
                                       (lambda (al ap as)
                                         (evens-only*&co (cdr lat)
                                                         (lambda (dl dp ds)
                                                           (col (cons al dl) (* ap dp) (+ as ds)))))))
    ((even? (car lat)) (evens-only*&co (cdr lat) (lambda (newl p s)
                                                   (col (cons (car lat) newl) (* (car lat) p) s))))
    (else (evens-only*&co (cdr lat) (lambda (newl p s)
                                      (col newl p (+ (car lat) s)))))))
(print
 (value '(3 + (4 my^ 5)))
 (value '(3 + ((4 x 3) my^ 5)))
 (multirembercol 'tuna '(strawberries tuna and swordfish)
                 (lambda (x y) (null? y)))
 (multirembercol 'tuna '()
                 (lambda (x y) (null? y)))
 (multirembercol 'tuna '(tuna)
                 (lambda (x y) (null? y)))
 
 (multirembercol 'tuna '(and tuna)
                 (lambda (x y) (null? y)))
 (multirembercol 'tuna '(strawberries tuna and swordfish)
                 (lambda (x y) (length y)))
 (multirembercol 'tuna '(strawberries tuna and tuna tuna tuna tuna swordfish tuna)
                 (lambda (x y) (length y)))
 (evens-only* '(1 2 3 4 5 6 7 8 9 10 11))
 (evens-only* '(1 2 3 4 (1 2 3 4 5 6 (1 2 3 4 5 (1 2 3 4 5 6 7 8 9 10 11) 6 7 8 9 10 11) 7 8 9 10 11) 5 6 7 8 9 (1 2 3 4 5 6 7 8 9 10 11) 10 11))
 (evens-only*&co '((9 1 2 8) 3 10 ((9 9) 7 6) 2) (lambda (newl product sum)
                                                   (cons sum
                                                         (cons product newl)))))
;;End of Chapter 8
;;Begin of Chapter 9
(define (looking a lat)
  (keep-looking a (pick 1 lat) lat))
(define (keep-looking a sorn lat)
  (cond
    ((number? sorn)
     (keep-looking a (pick sorn lat) lat))
    (else (eq? sorn a))))
(define (shift pair)
  (build (first (first pair))
         (build (second (first pair))
                (second pair))))
(define (align pora)
  (cond
    ((atom? pora) pora)
    ((a-pair? (first pora)) (align (shift pora)))
    (else (build (first pora)
                 (align (second pora))))))
(define (length* porn)
  (cond
    ((atom? porn) 1)
    (else (+ (length* (car porn))
             (length* (cdr porn))))))
(print
 (looking 'caviar '(6 2 4 caviar 5 7 3))
 (looking 'caviar '(6 2 grits caviar 5 7 3))
 (shift '((a b) c))
 (shift '((a b) (c d)))
 (align '(1 2 3 4 5 6))
 ;;(length* '(1 2 3 4 5 6))
 )
(define (eternity x)
  (eternity x))
;;可以计算length <= 0的情况
(print
 ((lambda (l)
    (cond
      ((null? l) 0)
      (else (+ 1 (eternity (cdr l)))))) '()))
;;可以计算length <= 1的情况
(print
 ((lambda (l)
    (cond
      ((null? l) 0)
      (else (+ 1 ((lambda (l)
                    (cond
                      ((null? l) 0)
                      (else (+ 1 (eternity (cdr l)))))) (cdr l)))))) '(1)))
;;可以计算length <= 2的情况
(print
 ((lambda (l)
    (cond
      ((null? l) 0)
      (else (+ 1 ((lambda (l)
                    (cond
                      ((null? l) 0)
                      (else (+ 1 ((lambda (l)
                                    (cond
                                      ((null? l) 0)
                                      (else (+ 1 (eternity (cdr l)))))) (cdr l)))))) (cdr l)))))) '(1 1)))
;;<=0
(print
 (((lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (+ 1 (length (cdr l))))))) eternity) '()))
;;<=1
(print
 (((lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (+ 1 (length (cdr l))))))) ((lambda (length)
                                             (lambda (l)
                                               (cond
                                                 ((null? l) 0)
                                                 (else (+ 1 (length (cdr l))))))) eternity)) '(1)))
;;<=2
(print
 (((lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (+ 1 (length (cdr l))))))) ((lambda (length)
                                             (lambda (l)
                                               (cond
                                                 ((null? l) 0)
                                                 (else (+ 1 (length (cdr l))))))) ((lambda (length)
                                                                                     (lambda (l)
                                                                                       (cond
                                                                                         ((null? l) 0)
                                                                                         (else (+ 1 (length (cdr l))))))) eternity))) '(1 1)))
;;<=0
(print
 (((lambda (mk-length)
     (mk-length eternity))
   (lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 (length (cdr l)))))))) '()))
;;<=1
(print
 (((lambda (mk-length)
     (mk-length
      (mk-length eternity)))
   (lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 (length (cdr l)))))))) '(1)))
;;<=2
(print
 (((lambda (mk-length)
     (mk-length
      (mk-length
       (mk-length eternity))))
   (lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 (length (cdr l)))))))) '(1 1)))
;;<=0
(print
 (((lambda (mk-length)
     (mk-length mk-length))
   (lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 (length (cdr l)))))))) '()))
;<=1
(print
 (((lambda (mk-length)
     (mk-length mk-length))
   (lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 ((length eternity) (cdr l)))))))) '(1)))
;
(print
 (((lambda (mk-length)
     (mk-length mk-length))
   (lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 ((length length) (cdr l)))))))) '(1 2 3 4 5 6 a b c s d e s x c)))
;修改上面函数
;可是进入无限循环
;; (print
;;  (((lambda (mk-length)
;;      (mk-length mk-length))
;;    (lambda (mk-length)
;;      ((lambda (length)
;;         (lambda (l)
;;           (cond
;;             ((null? l) 0)
;;             (else (add1 (length (cdr l)))))))
;;       (mk-length mk-length)))) '(1 2 3 4 5)))
 
(print
 (((lambda (mk-length)
     (mk-length mk-length))
   (lambda (mk-length)
     ((lambda (length)
        (lambda (l)
          (cond
            ((null? l) 0)
            (else (add1 (length (cdr l)))))))
      (lambda (x)
        ((mk-length mk-length) x))))) '(1 2 3 4 5)))
;定义在函数体内就可以引用函数名了
(((lambda (le)
    ((lambda (mk-length)
       (mk-length mk-length))
     (lambda (mk-length)
       (le (lambda (x)
             ((mk-length mk-length) x))))))
  (lambda (length)
    (lambda (l)
      (cond
        ((null? l) 0)
        (else (add1 (length (cdr l)))))))) '(s d f g e c))
;;定义形式就如同define
(define my-length
  (lambda (l)
    (cond
      ((null? l) 0)
      (else (add1 (my-length (cdr l)))))))
(print (my-length '(1 2 3)))
;;applicative-order Y combinator
(define Y
  (lambda (le)
    ((lambda (f) (f f))
     (lambda (f)
       (le (lambda (x) ((f f) x)))))))
(define (Y le)
  ((lambda (f) (f f))
   (lambda (f)
     (le (lambda (x) ((f f) x))))))
;;End of Chapter 9

The Little Schemer的笔记，直接复制放在Racket里面运行，查看结果。