Skip to content

Instantly share code, notes, and snippets.

@takuya0301

takuya0301/the-seasoned-schemer.rkt

Last active January 4, 2018 14:22
Show Gist options

  • Select an option

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

Select an option

Learn more about clone URLs
Save takuya0301/bdc54971ca75f22470a0dbc68ce8bcb4 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
the-seasoned-schemer.rkt
#lang racket/base
; Chapter 11
;(define member?
; (lambda (a lat)
; (cond
; ((null? lat) #f)
; (else (or (eq? a (car lat))
; (member? a (cdr lat)))))))
(define is-first?
(lambda (a lat)
(cond
((null? lat) #f)
(else (eq? (car lat) a)))))
;(define two-in-a-row?
; (lambda (lat)
; (cond
; ((null? lat) #f)
; (else
; (or (is-first? (car lat) (cdr lat))
; (two-in-a-row? (cdr lat)))))))
;(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? (car lat) a)
(two-in-a-row? lat))))))
(define two-in-a-row-b?
(lambda (preceding lat)
(cond
((null? lat) #f)
(else (or (eq? (car lat) preceding)
(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)))
(define one?
(lambda (n)
(= n 1)))
(define pick
(lambda (n lat)
(cond
((one? n) (car lat))
(else (pick (sub1 n) (cdr lat))))))
(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 ()))))
; Chapter 12
(define Y
(lambda (le)
((lambda (f) (f f))
(lambda (f)
(le (lambda (x) ((f f) x)))))))
;(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)))
(define ???
((lambda (le)
((lambda (f) (f f))
(lambda (f)
(le (lambda (x) ((f f) x))))))
(lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else
(add1 (length (cdr l)))))))))
(define length
(Y (lambda (length)
(lambda (l)
(cond
((null? l) 0)
(else
(add1 (length (cdr l)))))))))
;(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 mr
; (lambda (lat)
; (cond
; ((null? lat) (quote ()))
; ((eq? a (car lat))
; (mr (cdr lat)))
; (else
; (cons (car lat)
; (mr (cdr lat)))))))
;(define multirember
; (lambda (a lat)
; (mr lat)))
;(define multirember
; (lambda (a a-lat)
; (mr a-lat)))
;(define id
; (lambda (a)
; a))
(define id
(lambda (b)
b))
;(define multirember
; (lambda (b a-lat)
; (mr a-lat)))
(define mrpie
(lambda (lat)
(cond
((null? lat) (quote ()))
((eq? (car lat) (quote pie))
(mrpie (cdr lat)))
(else (cons (car lat)
(mrpie (cdr 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))))
(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 test? eq?)
(define rember-eq? (rember-f test?))
;(define multirember-f
; (lambda (test?)
; (lambda (a lat)
; (cond
; ((null? lat) (quote ()))
; ((test? (car lat) a)
; ((multirember-f test?) a
; (cdr lat)))
; (else (cons (car lat)
; ((multirember-f test?) a
; (cdr lat))))))))
(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 multirember
; (letrec
; ((mr (lambda (a lat)
; (cond
; ((null? lat) (quote ()))
; ((eq? (car lat) a)
; (mr a (cdr lat)))
; (else
; (cons (car lat)
; (mr a (cdr lat))))))))
; mr))
;(define multirember
; (letrec
; ((multirember
; (lambda (a lat)
; (cond
; ((null? lat) (quote ()))
; ((eq? (car lat) a)
; (multirember a (cdr lat)))
; (else
; (cons (car lat)
; (multirember a
; (cdr lat))))))))
; multirember))
(define multirember
(lambda (a lat)
(cond
((null? lat) (quote ()))
((eq? (car lat) a)
(multirember a (cdr lat)))
(else
(cons (car lat)
(multirember a (cdr lat)))))))
;(define member?
; (lambda (a lat)
; ((letrec
; ((yes? (lambda (l)
; (cond
; ((null? l) #f)
; ((eq? (car l) a) #t)
; (else (yes? (cdr l)))))))
; yes?)
; lat)))
(define member?
(lambda (a lat)
(letrec
((yes? (lambda (l)
(cond
((null? l) #f)
((eq? (car l) a) #t)
(else (yes? (cdr l)))))))
(yes? lat))))
;(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 union
; (lambda (set1 set2)
; (letrec
; ((U (lambda (set)
; (cond
; ((null? set) set2)
; ((member? (car set) set2)
; (U (cdr set)))
; (else (cons (car set)
; (U (cdr set))))))))
; (U set1))))
;(define member?
; (lambda (lat a)
; (cond
; ((null? lat) #f)
; ((eq (car lat) a) #t)
; (else (member? (cdr lat) a)))))
;(define union
; (lambda (set1 set2)
; (letrec
; ((U (lambda (set)
; (cond
; ((null? set) set2)
; ((M? (car set) set2)
; (U (cdr set)))
; (else (cons (car set)
; (U (cdr set)))))))
; (M? (lambda (a lat)
; (cond
; ((null? lat) #f)
; ((eq? (car lat) a) #t)
; (else
; (M? a (cdr lat)))))))
; (U set1))))
(define union
(lambda (set1 set2)
(letrec
((U (lambda (set)
(cond
((null? set) set2)
((M? (car set) set2)
(U (cdr set)))
(else (cons (car set)
(U (cdr set)))))))
(M? (lambda (a lat)
(letrec
((N? (lambda (lat)
(cond
((null? lat) #f)
((eq? (car lat) a) #t)
(else (N? (cdr lat)))))))
(N? lat)))))
(U set1))))
;(define two-in-a-row?
; (lambda (lat)
; (letrec
; ((W (lambda (a lat)
; (cond
; ((null? lat) #f)
; (else (or (eq? (car lat) a)
; (W (car lat)
; (cdr lat))))))))
; (cond
; ((null? lat) #f)
; (else (W (car lat) (cdr lat)))))))
(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)))))))
(define sum-of-prefixes
(lambda (tup)
(letrec
((S (lambda (sss tup)
(cond
((null? tup) (quote ()))
(else
(cons (+ sss (car tup))
(S (+ sss (car tup))
(cdr tup))))))))
(S 0 tup))))
;(define scramble
; (lambda (tup)
; (letrec
; ((P (lambda (tup rp)
; (cond
; ((null? tup) (quote ()))
; (else (cons (pick (car tup)
; (cons (car tup) rp))
; (P (cdr tup)
; (cons (car tup) rp))))))))
; (P tup (quote ())))))
;(define scramble
; (letrec
; ((P (lambda (tup rp)
; (cond
; ((null? tup) (quote ()))
; (else (cons (pick (car tup)
; (cons (car tup) rp))
; (P (cdr tup)
; (cons (car tup) rp))))))))
; (lambda (tup)
; (P tup (quote ())))))
; Chapter 13
;(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 intersect
; (lambda (set1 set2)
; (letrec
; ((I (lambda (set)
; (cond
; ((null? set) (quote ()))
; ((member? (car set) set2)
; (cons (car set)
; (I (cdr set))))
; (else (I (cdr set)))))))
; (I set1))))
;(define intersectall
; (lambda (lset)
; (cond
; ((null? (cdr lset)) (car lset))
; (else (intersect (car lset)
; (intersectall (cdr lset)))))))
;(define intersectall
; (lambda (lset)
; (cond
; ((null? lset) (quote ()))
; ((null? (cdr lset)) (car lset))
; (else (intersect (car lset)
; (intersectall
; (cdr lset)))))))
;(define intersectall
; (lambda (lset)
; (letrec
; ((intersectall
; (lambda (lset)
; (cond
; ((null? (cdr lset))
; (car lset))
; (else (intersect (car lset)
; (intersectall
; (cdr lset))))))))
; (cond
; ((null? lset) (quote ()))
; (else (intersectall lset))))))
;(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))))))
;(define intersectall
; (lambda (lset)
; (let/cc 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)
; (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 intersect
(lambda (set1 set2)
(letrec
((I (lambda (set1)
(cond
((null? set1) (quote ()))
((member? (car set1)
set2)
(cons (car set1)
(I (cdr set1))))
(else (I (cdr set1)))))))
(cond
((null? set2) (quote ()))
(else (I set1))))))
;(define intersectall
; (lambda (lset)
; (let/cc hop
; (letrec
; ((A (lambda (lset)
; (cond
; ((null? (car lset))
; (hop (quote ())))
; ((null? (cdr lset))
; (car lset))
; (else (I (car lset)
; (A (cdr lset)))))))
; (I (lambda (s1 s2)
; (letrec
; ((J (lambda (s1)
; (cond
; ((null? s1) (quote ()))
; ((member? (car s1) s2)
; (cons (car s1)
; (J (cdr s1))))
; (else (J (cdr s1)))))))
; (cond
; ((null? s2) (quote ()))
; (else (J s1)))))))
; (cond
; ((null? lset) (quote ()))
; (else (A lset)))))))
(define intersectall
(lambda (lset)
(let/cc hop
(letrec
((A (lambda (lset)
(cond
((null? (car lset))
(hop (quote ())))
((null? (cdr lset))
(car lset))
(else (I (car lset)
(A (cdr lset)))))))
(I (lambda (s1 s2)
(letrec
((J (lambda (s1)
(cond
((null? s1) (quote ()))
((member? (car s1) s2)
(cons (car s1)
(J (cdr s1))))
(else (J (cdr s1)))))))
(cond
((null? s2) (hop (quote ())))
(else (J s1)))))))
(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))))
(define rember-beyond-first
(lambda (a lat)
(letrec
((R (lambda (lat)
(cond
((null? lat) (quote ()))
((eq? (car lat) a) (quote ()))
(else (cons (car lat)
(R (cdr lat))))))))
(R lat))))
(define rember-upto-last
(lambda (a lat)
(let/cc skip
(letrec
((R (lambda (lat)
(cond
((null? lat) (quote ()))
((eq? (car lat) a)
(skip (R (cdr lat))))
(else (cons (car lat)
(R (cdr lat))))))))
(R lat)))))
; Chapter 14
(define atom?
(lambda (x)
(and (not (pair? x)) (not (null? x)))))
;(define leftmost
; (lambda (l)
; (cond
; ((atom? (car l)) (car l))
; (else (leftmost (car l))))))
;(define leftmost
; (lambda (l)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l)) (car l))
; (else (cond
; ((atom? (leftmost (car l)))
; (leftmost (car l)))
; (else (leftmost (cdr l))))))))
;(define leftmost
; (lambda (l)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l)) (car l))
; (else
; (let ((a (leftmost (car l))))
; (cond
; ((atom? a) a)
; (else (leftmost (cdr l)))))))))
(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 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
; (cond
; ((eqlist?
; (rember1* a (car l))
; (car l))
; (cons (car l)
; (rember1* a (cdr l))))
; (else (cons (rember1* a (car l))
; (cdr l))))))))
;(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
; (cond
; ((eqlist?
; (rember1* a (car l))
; (car l))
; (cons (car l)
; (rember1* a (cdr l))))
; (else (cons (rember1* a (car l))
; (cdr l))))))))
;(define rember1*
; (lambda (a l)
; (letrec
; ((R (lambda (l)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l))
; (cond
; ((eq? (car l) a) (cdr l))
; (else (cons (car l)
; (R (cdr l))))))
; (else
; (cond
; ((eqlist?
; (R (car l))
; (car l))
; (cons (car l)
; (R (cdr l))))
; (else (cons (R (car l))
; (cdr l)))))))))
; (R l))))
;(define rember1*
; (lambda (a l)
; (letrec
; ((R (lambda (l)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l))
; (cond
; ((eq? (car l) a) (cdr l))
; (else (cons (car l)
; (R (cdr l))))))
; (else
; (let ((av (R (car l))))
; (cond
; ((eqlist? (car l) av)
; (cons (car l) (R (cdr l))))
; (else (cons av (cdr l))))))))))
; (R l))))
;(define depth*
; (lambda (l)
; (cond
; ((null? l) 1)
; ((atom? (car l))
; (depth* (cdr l)))
; (else
; (cond
; ((> (depth* (cdr l))
; (add1 (depth* (car l))))
; (depth* (cdr l)))
; (else
; (add1 (depth* (car l)))))))))
;(define depth*
; (lambda (l)
; (let ((a (add1 (depth* (car l))))
; (d (depth* (cdr l))))
; (cond
; ((null? l) 1)
; ((atom? (car l))
; (depth* (cdr l)))
; (else
; (cond
; ((> d a) d)
; (else a)))))))
;(define depth*
; (lambda (l)
; (cond
; ((null? l) 1)
; ((atom? (car l))
; (depth* (cdr l)))
; (else
; (let ((a (add1 (depth* (car l))))
; (d (depth* (cdr l))))
; (cond
; ((> d a) d)
; (else a)))))))
;(define depth*
; (lambda (l)
; (cond
; ((null? l) 1)
; (else
; (let (
; (d (depth* (cdr l))))
; (cond
; ((atom? (car l)) d)
; (else
; (cond
; ((> d (add1 (depth* (car l)))) d)
; (else (add1 (depth* (car l))))))))))))
;(define depth*
; (lambda (l)
; (cond
; ((null? l) 1)
; (else
; (let (
; (d (depth* (cdr l))))
; (cond
; ((atom? (car l)) d)
; (else
; (let ((a (add1 (depth* (car l)))))
; (cond
; ((> d a) d)
; (else a))))))))))
;(define depth*
; (lambda (l)
; (cond
; ((null? l) 1)
; ((atom? (car l))
; (depth* (cdr l)))
; (else
; (let ((a (add1 (depth* (car l))))
; (d (depth* (cdr l))))
; (if (> d a) d a))))))
(define max
(lambda (n m)
(if (> n m) n m)))
;(define depth*
; (lambda (l)
; (cond
; ((null? l) 1)
; ((atom? (car l))
; (depth* (cdr l)))
; (else
; (let ((a (add1 (depth* (car l))))
; (d (depth* (cdr l))))
; (max a d))))))
(define depth*
(lambda (l)
(cond
((null? l) 1)
((atom? (car l))
(depth* (cdr l)))
(else
(max (add1 (depth* (car l)))
(depth* (cdr l)))))))
(define scramble
(lambda (tup)
(letrec
((P (lambda (tup rp)
(cond
((null? tup) (quote ()))
(else
(let ((rp (cons (car tup) rp)))
(cons (pick (car tup) rp)
(P (cdr tup) rp))))))))
(P tup (quote ())))))
;(define leftmost
; (lambda (l)
; (let/cc 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))))))
;(define leftmost
; (letrec
; ((lm (lambda (l out)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l))
; (out (car l)))
; (else
; (let ()
; (lm (car l) out)
; (lm (cdr l) out)))))))
; (lambda (l)
; (let/cc skip
; (lm l skip)))))
;(define leftmost
; (lambda (l)
; (letrec
; ((lm (lambda (l out)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l))
; (out (car l)))
; (else
; (let ()
; (lm (car l) out)
; (lm (cdr l) out)))))))
;
; (let/cc skip
; (lm l skip)))))
;(define leftmost
; (lambda (l)
; (let/cc skip
; (letrec
; ((lm (lambda (l out)
; (cond
; ((null? l) (quote ()))
; ((atom? (car l))
; (out (car l)))
; (else
; (let ()
; (lm (car l) out)
; (lm (cdr l) out)))))))
; (lm l skip)))))
(define leftmost
(lambda (l)
(let/cc skip
(letrec
((lm (lambda (l)
(cond
((null? l) (quote ()))
((atom? (car l))
(skip (car l)))
(else
(let ()
(lm (car l))
(lm (cdr l))))))))
(lm 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
; (if (atom?
; (let/cc oh
; (rm a (car l) oh)))
; (cons (car l)
; (rm a (cdr l) oh))
; (cons (rm a (car l) 0)
; (cdr l)))))))
;(define rember1*
; (lambda (a l)
; (if (atom? (let/cc oh (rm a l oh)))
; l
; (rm a l (quote ())))))
;(define rember1*
; (lambda (a l)
; (let ((new-l (let/cc oh (rm a l oh))))
; (if (atom? new-l)
; l
; new-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
; (let ((new-car
; (let/cc oh
; (rm a (car l) oh))))
; (if (atom? new-car)
; (cons (car l)
; (rm a (cdr l) oh))
; (cons new-car (cdr l))))))))
(define-syntax-rule (try x a b)
(let/cc success
(let/cc x (success a))
b))
(define rember1*
(lambda (a l)
(try oh (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
(try oh2
(cons (rm a (car l) oh2)
(cdr l))
(cons (car l)
(rm a (cdr l) oh)))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment