Skip to content

Instantly share code, notes, and snippets.

@takuya0301

takuya0301/the-little-schemer.rkt

Last active June 2, 2016 07:16
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save takuya0301/ab8ff767e2eb4592bdc1f2e6546d4fe1 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save takuya0301/ab8ff767e2eb4592bdc1f2e6546d4fe1 to your computer and use it in GitHub Desktop.
Download ZIP
The Little Schemer
Raw
the-little-schemer.rkt
#lang racket/base
; Chapter 1
(define atom?
(lambda (x)
(and (not (pair? x)) (not (null? x)))))
; Chapter 2
(define lat?
(lambda (l)
(cond
((null? l) #t)
((atom? (car l)) (lat? (cdr l)))
(else #f))))
(define member?
(lambda (a lat)
(cond
((null? lat) #f)
(else (or (eq? (car lat) a)
(member? a (cdr lat)))))))
; Chapter 3
;(define rember
; (lambda (a lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) a) (cdr lat))
; (else (rember a (cdr lat))))))))
;(define rember
; (lambda (a lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) a) (cdr lat))
; (else (cons (car lat)
; (rember a (cdr lat)))))))))
;(define rember
; (lambda (a lat)
; (cond
; ((null? lat) (quote()))
; ((eq? (car lat) a) (cdr lat))
; (else (cons (car lat)
; (rember a (cdr lat)))))))
(define firsts
(lambda (l)
(cond
((null? l) (quote ()))
(else (cons (car (car l))
(firsts (cdr l)))))))
;(define insertR
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else
; (cond
; ((eq? (car lat) old) (cdr lat))
; (else (cons (car lat)
; (insertR new old
; (cdr lat)))))))))
;(define insertR
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) old)
; (cons new (cdr lat)))
; (else (cons (car lat)
; (insertR new old
; (cdr lat)))))))))
;(define insertR
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) old)
; (cons old
; (cons new (cdr lat))))
; (else (cons (car lat)
; (insertR new old
; (cdr lat)))))))))
;(define insertL
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) old)
; (cons new
; (cons old (cdr lat))))
; (else (cons (car lat)
; (insertL new old
; (cdr lat)))))))))
;(define insertL
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) old)
; (cons new lat))
; (else (cons (car lat)
; (insertL new old
; (cdr lat)))))))))
;(define subst
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) old)
; (cons new (cdr lat)))
; (else (cons (car lat)
; (subst new old
; (cdr lat)))))))))
;(define subst2
; (lambda (new o1 o2 lat)
; (cond
; ((null? lat) (quote ()))
; (else (cond
; ((eq? (car lat) o1)
; (cons new (cdr lat)))
; ((eq? (car lat) o2)
; (cons new (cdr lat)))
; (else (cons (car lat)
; (subst2 new o1 o2
; (cdr lat)))))))))
(define subst2
(lambda (new o1 o2 lat)
(cond
((null? lat) (quote ()))
(else (cond
((or (eq? (car lat) o1)
(eq? (car lat) o2))
(cons new (cdr lat)))
(else (cons (car lat)
(subst2 new o1 o2
(cdr lat)))))))))
(define multirember
(lambda (a lat)
(cond
((null? lat) (quote ()))
(else
(cond
((eq? (car lat) a)
(multirember a (cdr lat)))
(else (cons (car lat)
(multirember a
(cdr lat)))))))))
(define multiinsertR
(lambda (new old lat)
(cond
((null? lat) (quote ()))
(else
(cond
((eq? (car lat) old)
(cons (car lat)
(cons new
(multiinsertR new old
(cdr lat)))))
(else (cons (car lat)
(multiinsertR new old
(cdr lat)))))))))
;(define multiinsertL
; (lambda (new old lat)
; (cond
; ((null? lat) (quote ()))
; (else
; (cond
; ((eq? (car lat) old)
; (cons new
; (cons old
; (multiinsertL new old
; lat))))
; (else (cons (car lat)
; (multiinsertL new old
; (cdr lat)))))))))
(define multiinsertL
(lambda (new old lat)
(cond
((null? lat) (quote ()))
(else
(cond
((eq? (car lat) old)
(cons new
(cons old
(multiinsertL new old
(cdr lat)))))
(else (cons (car lat)
(multiinsertL new old
(cdr lat)))))))))
(define multisubst
(lambda (new old lat)
(cond
((null? lat) (quote ()))
(else (cond
((eq? (car lat) old)
(cons new
(multisubst new old
(cdr lat))))
(else (cons (car lat)
(multisubst new old
(cdr lat)))))))))
; Chapter 4
(define o+
(lambda (n m)
(cond
((zero? m) n)
(else (add1 (o+ n (sub1 m)))))))
(define o-
(lambda (n m)
(cond
((zero? m) n)
(else (sub1 (o- n (sub1 m)))))))
(define addtup
(lambda (tup)
(cond
((null? tup) 0)
(else (o+ (car tup) (addtup (cdr tup)))))))
(define o*
(lambda (n m)
(cond
((zero? m) 0)
(else (o+ n (o* n (sub1 m)))))))
;(define tup+
; (lambda (tup1 tup2)
; (cond
; ((and (null? tup1) (null? tup2))
; (quote ()))
; (else
; (cons (o+ (car tup1) (car tup2))
; (tup+
; (cdr tup1) (cdr tup2)))))))
;(define tup+
; (lambda (tup1 tup2)
; (cond
; ((and (null? tup1) (null? tup2))
; (quote ()))
; ((null? tup1) tup2)
; ((null? tup2) tup1)
; (else
; (cons (o+ (car tup1) (car tup2))
; (tup+
; (cdr tup1) (cdr tup2)))))))
(define tup+
(lambda (tup1 tup2)
(cond
((null? tup1) tup2)
((null? tup2) tup1)
(else
(cons (o+ (car tup1) (car tup2))
(tup+
(cdr tup1) (cdr tup2)))))))
;(define o>
; (lambda (n m)
; (cond
; ((zero? m) #t)
; ((zero? n) #f)
; (else (o> (sub1 n) (sub1 m))))))
(define o>
(lambda (n m)
(cond
((zero? n) #f)
((zero? m) #t)
(else (o> (sub1 n) (sub1 m))))))
(define o<
(lambda (n m)
(cond
((zero? m) #f)
((zero? n) #t)
(else (o< (sub1 n) (sub1 m))))))
;(define o=
; (lambda (n m)
; (cond
; ((zero? m) (zero? n))
; ((zero? n) #f)
; (else (o= (sub1 n) (sub1 m))))))
(define o=
(lambda (n m)
(cond
((> n m) #f)
((< n m) #f)
(else #t))))
(define o^
(lambda (n m)
(cond
((zero? m) 1)
(else (o* n (o^ n (sub1 m)))))))
(define ???
(lambda (n m)
(cond
((< n m) 0)
(else (add1 (??? (o- n m) m))))))
(define o/
(lambda (n m)
(cond
((< n m) 0)
(else (add1 (o/ (o- n m) m))))))
(define length
(lambda (lat)
(cond
((null? lat) 0)
(else (add1 (length (cdr lat)))))))
(define pick
(lambda (n lat)
(cond
((zero? (sub1 n)) (car lat))
(else (pick (sub1 n) (cdr lat))))))
;(define rempick
; (lambda (n lat)
; (cond
; ((zero? (sub1 n)) (cdr lat))
; (else (cons (car lat)
; (rempick (sub1 n)
; (cdr lat)))))))
(define no-nums
(lambda (lat)
(cond
((null? lat) (quote ()))
(else (cond
((number? (car lat))
(no-nums (cdr lat)))
(else (cons (car lat)
(no-nums
(cdr lat)))))))))
(define all-nums
(lambda (lat)
(cond
((null? lat) (quote ()))
(else (cond
((number? (car lat))
(cons (car lat)
(all-nums (cdr lat))))
(else (all-nums (cdr lat))))))))
(define eqan?
(lambda (a1 a2)
(cond
((and (number? a1) (number? a2))
(o= a1 a2))
((or (number? a1) (number? a2))
#f)
(else (eq? a1 a2)))))
(define occur
(lambda (a lat)
(cond
((null? lat) 0)
(else
(cond
((eq? (car lat) a)
(add1 (occur a (cdr lat))))
(else (occur a (cdr lat))))))))
;(define one?
; (lambda (n)
; (cond
; ((zero? n) #f)
; (else (zero? (sub1 n))))))
;(define one?
; (lambda (n)
; (cond
; (else (= n 1)))))
(define one?
(lambda (n)
(= n 1)))
(define rempick
(lambda (n lat)
(cond
((one? n) (cdr lat))
(else (cons (car lat)
(rempick (sub1 n)
(cdr lat)))))))
; Chapter 5
(define rember*
(lambda (a l)
(cond
((null? l) (quote()))
((atom? (car l))
(cond
((eq? (car l) a)
(rember* a (cdr l)))
(else (cons (car l)
(rember* a (cdr l))))))
(else (cons (rember* a (car l))
(rember* a (cdr l)))))))
(define insertR*
(lambda (new old l)
(cond
((null? l) (quote ()))
((atom? (car l))
(cond
((eq? (car l) old)
(cons old
(cons new
(insertR* new old
(cdr l)))))
(else (cons (car l)
(insertR* new old
(cdr l))))))
(else (cons (insertR* new old
(car l))
(insertR* new old
(cdr l)))))))
(define occur*
(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)))))))
(define subst*
(lambda (new old l)
(cond
((null? l) (quote ()))
((atom? (car l))
(cond
((eq? (car l) old)
(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)))))))
(define insertL*
(lambda (new old l)
(cond
((null? l) (quote ()))
((atom? (car l))
(cond
((eq? (car l) old)
(cons new (cons old (insertL* new old (cdr l)))))
(else (cons (car l) (insertL* new old (cdr l))))))
(else (cons (insertL* new old (car l))
(insertL* new old (cdr l)))))))
(define member*
(lambda (a l)
(cond
((null? l) #f)
((atom? (car l))
(or (eq? (car l) a)
(member* a (cdr l))))
(else (or (member* a (car l))
(member* a (cdr l)))))))
(define leftmost
(lambda (l)
(cond
((atom? (car l)) (car l))
(else (leftmost (car l))))))
;(define eqlist?
; (lambda (l1 l2)
; (cond
; ((and (null? l1) (null? l2)) #t)
; ((and (null? l1) (atom? (car l2)))
; #f)
; ((null? l1) #f)
; ((and (atom? (car l1)) (null? l2))
; #f)
; ((and (atom? (car l1)) (atom? (car l2)))
; (and (eqan? (car l1) (car l2))
; (eqlist? (cdr l1) (cdr l2))))
; ((atom? (car l1)) #f)
; ((null? l2) #f)
; ((atom? (car l2)) #f)
; (else
; (and (eqlist? (car l1) (car l2))
; (eqlist? (cdr l1) (cdr l2)))))))
;(define eqlist?
; (lambda (l1 l2)
; (cond
; ((and (null? l1) (null? l2)) #t)
; ((or (null? l1) (null? l2)) #f)
; ((and (atom? (car l1))
; (atom? (car l2)))
; (and (eqan? (car l1) (car l2))
; (eqlist? (cdr l1) (cdr l2))))
; ((or (atom? (car l1))
; (atom? (car l2)))
; #f)
; (else
; (and (eqlist? (car l1) (car l2))
; (eqlist? (cdr l1) (cdr l2)))))))
;(define equal?
; (lambda (s1 s2)
; (cond
; ((and (atom? s1) (atom? s2))
; (eqan? s1 s2))
; ((atom? s1) #f)
; ((atom? s2) #f)
; (else (eqlist? s1 s2)))))
(define equal?
(lambda (s1 s2)
(cond
((and (atom? s1) (atom? s2))
(eqan? s1 s2))
((or (atom? s1) (atom? s2)) #f)
(else (eqlist? s1 s2)))))
(define eqlist?
(lambda (l1 l2)
(cond
((and (null? l1) (null? l2)) #t)
((or (null? l1) (null? l2)) #f)
(else
(and (equal? (car l1) (car l2))
(eqlist? (cdr l1) (cdr l2)))))))
;(define rember
; (lambda (s l)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l))
; (cond
; ((equal? (car l) s) (cdr l))
; (else (cons (car l)
; (rember s (cdr l))))))
; (else (cond
; ((equal? (car l) s) (cdr l))
; (else (cons (car l)
; (rember s
; (cdr l)))))))))
;(define rember
; (lambda (s l)
; (cond
; ((null? l) (quote ()))
; (else (cond
; ((equal? (car l) s) (cdr l))
; (else (cons (car l)
; (rember s
; (cdr l)))))))))
(define rember
(lambda (s l)
(cond
((null? l) (quote ()))
((equal? (car l) s) (cdr l))
(else (cons (car l)
(rember s (cdr l)))))))
; Chapter 6
;(define numbered?
; (lambda (aexp)
; (cond
; ((atom? aexp) (number? aexp))
; ((eq? (car (cdr aexp)) (quote +))
; (and (numbered? (car aexp))
; (numbered? (car (cdr (cdr aexp))))))
; ((eq? (car (cdr aexp)) (quote *))
; (and (numbered? (car aexp))
; (numbered? (car (cdr (cdr aexp))))))
; ((eq? (car (cdr aexp)) (quote ^))
; (and (numbered? (car aexp))
; (numbered? (car (cdr (cdr aexp)))))))))
(define numbered?
(lambda (aexp)
(cond
((atom? aexp) (number? aexp))
(else
(and (numbered? (car aexp))
(numbered?
(car (cdr (cdr aexp)))))))))
;(define value
; (lambda (nexp)
; (cond
; ((atom? nexp) nexp)
; ((eq? (car (cdr nexp)) (quote +))
; (o+ (value (car nexp))
; (value (car (cdr (cdr nexp))))))
; ((eq? (car (cdr nexp)) (quote *))
; (o* (value (car nexp))
; (value (car (cdr (cdr nexp))))))
; (else
; (o^ (value (car nexp))
; (value (car (cdr (cdr nexp)))))))))
;(define value
; (lambda (nexp)
; (cond
; ((atom? nexp) nexp)
; ((eq? (car nexp) (quote +))
; (o+ (value (car (cdr nexp)))
; (value (car (cdr (cdr nexp))))))
; ((eq? (car nexp) (quote *))
; (o* (value (car (cdr nexp)))
; (value (car (cdr (cdr nexp))))))
; (else
; (o^ (value (car (cdr nexp)))
; (value (car (cdr (cdr nexp)))))))))
;(define 1st-sub-exp
; (lambda (aexp)
; (cond
; (else (car (cdr aexp))))))
;(define 1st-sub-exp
; (lambda (aexp)
; (car (cdr aexp))))
(define 2nd-sub-exp
(lambda (aexp)
(car (cdr (cdr aexp)))))
;(define operator
; (lambda (aexp)
; (car aexp)))
;(define value
; (lambda (nexp)
; (cond
; ((atom? nexp) nexp)
; ((eq? (operator nexp) (quote +))
; (o+ (value (1st-sub-exp nexp))
; (value (2nd-sub-exp nexp))))
; ((eq? (operator nexp) (quote *))
; (o* (value (1st-sub-exp nexp))
; (value (2nd-sub-exp nexp))))
; (else
; (o^ (value (1st-sub-exp nexp))
; (value (2nd-sub-exp nexp)))))))
(define 1st-sub-exp
(lambda (aexp)
(car aexp)))
(define operator
(lambda (aexp)
(car (cdr aexp))))
(define sero?
(lambda (n)
(null? n)))
(define edd1
(lambda (n)
(cons (quote ()) n)))
(define zub1
(lambda (n)
(cdr n)))
(define x+
(lambda (n m)
(cond
((sero? m) n)
(else (edd1 (x+ n (zub1 m)))))))
; Chapter 7
;(define set?
; (lambda (lat)
; (cond
; ((null? lat) #t)
; (else
; (cond
; ((member? (car lat) (cdr lat))
; #f)
; (else (set? (cdr lat))))))))
(define set?
(lambda (lat)
(cond
((null? lat) #t)
((member? (car lat) (cdr lat)) #f)
(else (set? (cdr lat))))))
(define makeset
(lambda (lat)
(cond
((null? lat) (quote ()))
((member? (car lat) (cdr lat))
(makeset (cdr lat)))
(else (cons (car lat)
(makeset (cdr lat)))))))
;(define subset?
; (lambda (set1 set2)
; (cond
; ((null? set1) #t)
; (else (cond
; ((member? (car set1) set2)
; (subset? (cdr set1) set2))
; (else #f))))))
;(define subset?
; (lambda (set1 set2)
; (cond
; ((null? set1) #t)
; ((member? (car set1) set2)
; (subset? (cdr set1) set2))
; (else #f))))
(define subset?
(lambda (set1 set2)
(cond
((null? set1) #t)
(else
(and (member? (car set1) set2)
(subset? (cdr set1) set2))))))
;(define eqset?
; (lambda (set1 set2)
; (cond
; ((subset? set1 set2)
; (subset? set2 set1))
; (else #f))))
;(define eqset?
; (lambda (set1 set2)
; (cond
; (else (and (subset? set1 set2)
; (subset? set2 set1))))))
(define eqset?
(lambda (set1 set2)
(and (subset? set1 set2)
(subset? set2 set1))))
;(define intersect?
; (lambda (set1 set2)
; (cond
; ((null? set1) #f)
; (else
; (cond
; ((member? (car set1) set2) #t)
; (else (intersect?
; (cdr set1) set2)))))))
;(define intersect?
; (lambda (set1 set2)
; (cond
; ((null? set1) #f)
; ((member? (car set1) set2) #t)
; (else (intersect?
; (cdr set1) set2)))))
(define intersect?
(lambda (set1 set2)
(cond
((null? set1) #f)
(else (or (member? (car set1) set2)
(intersect?
(cdr set1) set2))))))
(define intersect
(lambda (set1 set2)
(cond
((null? set1) (quote ()))
((member? (car set1) set2)
(cons (car set1)
(intersect (cdr set1) set2)))
(else (intersect (cdr set1) set2)))))
(define union
(lambda (set1 set2)
(cond
((null? set1) set2)
((member? (car set1) set2)
(union (cdr set1) set2))
(else (cons (car set1)
(union (cdr set1) set2))))))
(define xxx
(lambda (set1 set2)
(cond
((null? set1) (quote ()))
((member? (car set1) set2)
(xxx (cdr set1) set2))
(else (cons (car set1)
(xxx (cdr set1) set2))))))
(define intersectall
(lambda (l-set)
(cond
((null? (cdr l-set)) (car l-set))
(else (intersect (car l-set)
(intersectall (cdr l-set)))))))
(define a-pair?
(lambda (x)
(cond
((atom? x) #f)
((null? x) #f)
((null? (cdr x)) #f)
((null? (cdr (cdr x))) #t)
(else #f))))
;(define first
; (lambda (p)
; (cond
; (else (car p)))))
;(define second
; (lambda (p)
; (cond
; (else (car (cdr p))))))
;(define build
; (lambda (a1 a2)
; (cond
; (else (cons a1
; (cons a2 (quote ())))))))
(define first
(lambda (p)
(car p)))
(define second
(lambda (p)
(car (cdr p))))
(define build
(lambda (a1 a2)
(cons a1
(cons a2 (quote())))))
(define third
(lambda (l)
(car (cdr (cdr l)))))
(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)))))))
;(define revrel
; (lambda (rel)
; (cond
; ((null? rel) (quote ()))
; (else (cons (cons
; (car (cdr (car rel)))
; (cons (car (car rel))
; (quote ())))
; (revrel (cdr rel)))))))
(define revpair
(lambda (pair)
(build (second pair) (first pair))))
(define revrel
(lambda (rel)
(cond
((null? rel) (quote ()))
(else (cons (revpair (car rel))
(revrel (cdr rel)))))))
(define fullfun?
(lambda (fun)
(set? (seconds fun))))
(define seconds
(lambda (l)
(cond
((null? l) (quote ()))
(else (cons (car (cdr (car l)))
(seconds (cdr l)))))))
(define one-to-one?
(lambda (fun)
(fun? (revrel fun))))
; Chapter 8
;(define rember-f
; (lambda (test? a l)
; (cond
; ((null? l) (quote ()))
; (else (cond
; ((test? (car l) a) (cdr l))
; (else (cons (car l)
; (rember-f test? a
; (cdr l)))))))))
;(define rember-f
; (lambda (test? a l)
; (cond
; ((null? l) (quote ()))
; ((test? (car l) a) (cdr l))
; (else (cons (car l)
; (rember-f test? a
; (cdr l)))))))
(define eq?-c
(lambda (a)
(lambda (x)
(eq? x a))))
(define eq?-salad (eq?-c (quote salad)))
(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 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 insertR-f
(lambda (test?)
(lambda (new old l)
(cond
((null? l) (quote ()))
((test? (car l) old)
(cons old (cons new (cdr l))))
(else (cons (car l)
((insertR-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 seqS
(lambda (new old l)
(cons new l)))
(define subst (insert-g seqS))
(define seqrem
(lambda (new old l)
l))
(define yyy
(lambda (a l)
((insert-g seqrem) #f a l)))
(define atom-to-function
(lambda (x)
(cond
((eq? x (quote +)) o+)
((eq? x (quote *)) o*)
(else o^))))
;(define value
; (lambda (nexp)
; (cond
; ((atom? nexp) nexp)
; (else
; ((atom-to-function
; (operator nexp))
; (value (1st-sub-exp nexp))
; (value (2nd-sub-exp nexp)))))))
(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))))))))
(define multirember-eq? (multirember-f eq?))
(define eq?-tuna (eq?-c (quote tuna)))
(define multiremberT
(lambda (test? lat)
(cond
((null? lat) (quote ()))
((test? (car lat))
(multiremberT test? (cdr lat)))
(else (cons (car lat)
(multiremberT test?
(cdr lat)))))))
(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 a-friend
(lambda (x y)
(null? y)))
(define new-friend
(lambda (newlat seen)
(a-friend newlat
(cons (quote tuna) seen))))
(define latest-friend
(lambda (newlat seen)
(a-friend (cons (quote and) newlat)
seen)))
(define last-friend
(lambda (x y)
(length x)))
(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 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)))))))
(define even?
(lambda (n)
(o= (o* (o/ n 2) 2) n)))
(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)))))))
(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)
(o* (car l) p) s))))
(else (evens-only*&co (cdr l)
(lambda (newl p s)
(col newl
p (o+ (car l) s)))))))
(else (evens-only*&co (car l)
(lambda (al ap as)
(evens-only*&co (cdr l)
(lambda (dl dp ds)
(col (cons al dl)
(o* ap dp)
(o+ as ds))))))))))
(define the-last-friend
(lambda (newl product sum)
(cons sum
(cons product
newl))))
; Chapter 9
(define looking
(lambda (a lat)
(keep-looking a (pick 1 lat) lat)))
(define keep-looking
(lambda (a sorn lat)
(cond
((number? sorn)
(keep-looking a (pick sorn lat) lat))
(else (eq? sorn a)))))
(define eternity
(lambda (x)
(eternity x)))
(define shift
(lambda (pair)
(build (first (first pair))
(build (second (first pair))
(second pair)))))
(define align
(lambda (para)
(cond
((atom? para) para)
((a-pair? (first para))
(align (shift para)))
(else (build (first para)
(align (second para)))))))
(define length*
(lambda (para)
(cond
((atom? para) 1)
(else
(o+ (length* (first para))
(length* (second para)))))))
(define weight*
(lambda (para)
(cond
((atom? para) 1)
(else
(o+ (o* (weight* (first para)) 2)
(weight* (second para)))))))
(define shuffle
(lambda (pora)
(cond
((atom? pora) pora)
((a-pair? (first pora))
(shuffle (revpair pora)))
(else (build (first pora)
(shuffle (second pora)))))))
(define C
(lambda (n)
(cond
((one? n) 1)
(else
(cond
((even? n) (C (o/ n 2)))
(else (C (add1 (o* 3 n)))))))))
(define A
(lambda (n m)
(cond
((zero? n) (add1 m))
((zero? m) (A (sub1 n) 1))
(else (A (sub1 n)
(A n (sub1 m)))))))
;(define will-stop?
; (lambda (f)
; ...))
;(define last-try
; (lambda (x)
; (and (will-stop? last-try)
; (eternity x))))
(lambda (l)
(cond
((null? l) 0)
(else (add1 (eternity (cdr l))))))
(lambda (l)
(cond
((null? l) 0)
(else
(add1
((lambda (l)
(cond
((null? l) 0)
(else (add1
(eternity (cdr l))))))
(cdr l))))))
(lambda (l)
(cond
((null? l) 0)
(else
(add1
((lambda (l)
(cond
((null? l) 0)
(else
(add1
((lambda (l)
(cond
((null? l) 0)
(else
(add1
(eternity
(cdr l))))))
(cdr l))))))
(cdr l))))))
((lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l)))))))
eternity)
((lambda (f)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (f (cdr l)))))))
((lambda (g)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (g (cdr l)))))))
eternity))
((lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l)))))))
((lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l)))))))
((lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l)))))))
eternity)))
((lambda (mk-length)
(mk-length eternity))
(lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l))))))))
((lambda (mk-length)
(mk-length
(mk-length eternity)))
(lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l))))))))
((lambda (mk-length)
(mk-length
(mk-length
(mk-length eternity))))
(lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l))))))))
((lambda (mk-length)
(mk-length
(mk-length
(mk-length
(mk-length eternity)))))
(lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l))))))))
((lambda (mk-length)
(mk-length mk-length))
(lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (length (cdr l))))))))
((lambda (mk-length)
(mk-length mk-length))
(lambda (mk-length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 (mk-length (cdr l))))))))
((lambda (mk-length)
(mk-length mk-length))
(lambda (mk-length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 ((mk-length eternity) (cdr l))))))))
((lambda (mk-length)
(mk-length mk-length))
(lambda (mk-length)
(lambda (l)
(cond
((null? l) 0)
(else (add1 ((mk-length mk-length) (cdr l))))))))
;((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))))
((lambda (mk-length)
(mk-length mk-length))
(lambda (mk-length)
(lambda (l)
(cond
((null? l) 0)
(else
(add1
((lambda (x)
((mk-length mk-length) x))
(cdr l))))))))
((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)))))
((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))))))))
(lambda (le)
((lambda (mk-length)
(mk-length mk-length))
(lambda (mk-length)
(le (lambda (x)
((mk-length mk-length) x))))))
(define Y
(lambda (le)
((lambda (f) (f f))
(lambda (f)
(le (lambda (x) ((f f) x)))))))
; Chapter 10
(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)))))
(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 (name)
(lookup-in-table name
(cdr table)
table-f)))))))
(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 cond))
*cond)
(else *application)))
(else *application))))
(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)))))
(define *quote
(lambda (e table)
(text-of e)))
(define text-of second)
(define *identifier
(lambda (e table)
(lookup-in-table e table initial-table)))
(define initial-table
(lambda (name)
(car (quote ()))))
(define *lambda
(lambda (e table)
(build (quote non-primitive)
(cons table (cdr e)))))
(define table-of first)
(define formals-of second)
(define body-of third)
(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))))))
(define *application
(lambda (e table)
(apply
(meaning (function-of e) table)
(evlis (arguments-of e) table))))
(define function-of car)
(define arguments-of cdr)
(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))))))
(define :atom?
(lambda (x)
(cond
((atom? x) #t)
((null? x) #f)
((eq? (car x) (quote primitive))
#t)
((eq? (car x) (quote non-primitive))
#f)
(else #f))))
(define apply-closure
(lambda (closure vals)
(meaning (body-of closure)
(extend-table
(new-entry
(formals-of closure)
vals)
(table-of closure)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment