Programs must be written for people to read, and only incidentally for machines to execute.
(define Y
(lambda (h)
((lambda (f) (f f))
(lambda (g)
(h (lambda (x) ((g g) x)))))))(define (fib n)
(if (< n 2)
n
(+ (fib (- n 1))
(fib (- n 2)))))(define (fib n)
(let iter ((a 0) (b 1) (c 0))
(if (= c n)
a
(iter b (+ a b) (+ c 1)))))(define (fact n)
(if (= n 0)
1
(* n (fact (- n 1)))))(define ((up n) a b)
(cond ((zero? n) (* a b))
((zero? b) 1)
(else
((up (sub1 n)) a ((up n) a (sub1 b))))))(define ((repeated n) f)
(if (zero? n)
identity
(compose f ((repeated (sub1 n)) f))))
(define (f n) ((up n) 3 3))
(define f64 ((repeated 64) f))
(define G (f64 4))(define (shuffle! v)
(define l (vector-length v))
(let iter ((i l))
(unless (< i 2)
(vector-swap! v (random i) (- i 1))
(iter (- i 1)))))(define (P n k)
(let iter ((n n) (k k) (r 1))
(if (= k 0)
r
(iter (- n 1) (- k 1) (* n r)))))
(define (C n k)
(let ((k (min k (- n k))))
(/ (P n k) (fact k))))(define (sign-of-permutation permutation)
(define p (vector-copy permutation))
(define l (vector-length p))
(define q (make-vector l))
(let iter ((i 0))
(unless (= i l)
(define x (vector-ref p i))
(vector-set! q x i)
(iter (+ i 1))))
(let iter ((i 0) (s 1))
(if (= i l)
s
(let ((x (vector-ref p i)))
(if (= i x)
(iter (+ i 1) s)
(let ((j (vector-ref q i)))
(vector-swap! p i j)
(vector-swap! q x i)
(iter (+ i 1) (- s))))))))(define (product . lst*)
(if (null? lst*)
'(())
(append-map
(lambda (d)
(map (lambda (a) (cons a d))
(car lst*)))
(apply product (cdr lst*)))))(define (gcd a b)
(if (= b 0)
a
(gcd b (remainder a b))))(define (ext-gcd a b)
(if (= b 0)
(values a 1 0)
(let ((q (quotient a b))
(r (remainder a b)))
(let-values (((d m n) (ext-gcd b r)))
(values d n (- m (* q n)))))))(define (divides? a b)
(= (remainder b a) 0))
(define (make-ints n)
($cons n (make-ints (+ n 1))))
(define (sieve $)
($cons ($car $)
(sieve
($filter (lambda (x)
(not (divides? ($car $) x)))
($cdr $)))))
(define primes
(sieve (make-ints 2)))(define (base-convert n b)
(let iter ((n n) (r '()))
(if (= n 0)
r
(iter (quotient n b)
(cons (remainder n b) r)))))(define (make-counter)
(let ((x -1))
(lambda ()
(set! x (+ x 1))
x)))(define (make-pt x y) (vector 'pt x y))
(define (pt-x pt) (vector-ref pt 1))
(define (pt-y pt) (vector-ref pt 2))
(define (make-vec x y) (vector 'vec x y))
(define (vec-x vec) (vector-ref vec 1))
(define (vec-y vec) (vector-ref vec 2))
;pt- : pt * pt -> vec
(define (pt- p1 p2)
(make-vec
(- (pt-x p1) (pt-x p2))
(- (pt-y p1) (pt-y p2))))
;pt+ : pt * vec -> pt
(define (pt+ p v)
(make-pt
(+ (pt-x p) (vec-x v))
(+ (pt-y p) (vec-y v))))
;vec* : real * vec -> vec
(define (vec* k v)
(make-vec
(* k (vec-x v))
(* k (vec-y v))))
;lerp : real -> pt * pt -> pt
(define ((lerp t) p1 p2)
(pt+ p1 (vec* t (pt- p2 p1))))
;deCasteljau : pt* -> real -> pt
(define ((deCasteljau p*) t)
(let iter ((p* p*))
(if (null? (cdr p*))
(car p*)
(iter (map (lerp t)
(drop-right p* 1)
(cdr p*))))))(define (isort l)
(if (null? l)
'()
(insert (car l) (isort (cdr l)))))
(define (insert x l)
(cond ((null? l) (list x))
((<= x (car l)) (cons x l))
(else
(cons (car l)
(insert x (cdr l))))))(define (qsort l)
(if (or (null? l) (null? (cdr l)))
l
(let-values (((left middle right) (partition l)))
(append (qsort left) middle (qsort right)))))
(define (partition l)
(define pivot (car l))
(let iter ((left '()) (middle '()) (right '()) (rest l))
(cond ((null? rest) (values left middle right))
((< (car rest) pivot)
(iter (cons (car rest) left) middle right (cdr rest)))
((= (car rest) pivot)
(iter left (cons pivot middle) right (cdr rest)))
(else
(iter left middle (cons (car rest) right) (cdr rest))))))(define-syntax match
(syntax-rules (guard)
((_ v) (error 'match "~s" v))
((_ v (pat (guard g ...) e ...) cs ...)
(let ((fk (lambda () (match v cs ...))))
(ppat v pat (if (and g ...) (let () e ...) (fk)) (fk))))
((_ v (pat e ...) cs ...)
(let ((fk (lambda () (match v cs ...))))
(ppat v pat (let () e ...) (fk))))))
(define-syntax ppat
(syntax-rules (unquote)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf)
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(ppat vx x (ppat vy y kt kf) kf))
kf))
((_ v lit kt kf) (if (eqv? v (quote lit)) kt kf))))(define zero
(lambda (f)
(lambda (x)
x)))
(define one
(lambda (f)
(lambda (x)
(f x))))
(define true
(lambda (x)
(lambda (y)
x)))
(define false
(lambda (x)
(lambda (y)
y)))
(define cons
(lambda (x)
(lambda (y)
(lambda (m)
((m x) y)))))
(define car
(lambda (p)
(p true)))
(define cdr
(lambda (p)
(p false)))
(define succ
(lambda (n)
(lambda (f)
(lambda (x)
(f ((n f) x))))))
(define pred
(lambda (n)
(car
((n (lambda (p)
((cons (cdr p)) (succ (cdr p)))))
((cons zero) zero)))))(define (varZ env) (car env))
(define ((varS vp) env)
(vp (cdr env)))
(define ((lam e) env)
(lambda (x)
(e (cons x env))))
(define ((app e1 e2) env)
((e1 env) (e2 env)))(define (empty-dict) '())
(define (ext-dict key val dict)
(cons (list key val) dict))
(define (lookup key dict)
(assq key dict))
(define (bd-val bd) (cadr bd))
;<var> ::= (? <symbol>)
;<seg-var> ::= (?? <symbol>)
(define (var-id v) (cadr v))
;<const> ::= <number>
; | <boolean>
; | <symbol>
(define (const? x)
(or (number? x)
(boolean? x)
(symbol? x)))
(define (Const c)
(lambda (x* dict succ fail)
(cond ((null? x*) (fail))
((eqv? (car x*) c)
(succ (cdr x*) dict fail))
(else (fail)))))
(define (Var id)
(lambda (x* dict succ fail)
(if (null? x*)
(fail)
(let ((bd (lookup id dict)))
(if bd
(let ((val (bd-val bd)))
(if (equal? val (car x*))
(succ (cdr x*) dict fail)
(fail)))
(succ (cdr x*)
(ext-dict id (car x*) dict)
fail))))))
(define (Seq2 m1 m2)
(lambda (x* dict succ fail)
(m1 x* dict
(lambda (x* dict fail)
(m2 x* dict succ fail))
fail)))
(define (Succ)
(lambda (x* dict succ fail)
(succ x* dict fail)))
(define (Fail)
(lambda (x* dict succ fail)
(fail)))
(define (Seq . m*)
(if (null? m*)
(Succ)
(let iter ((m (car m*))
(m* (cdr m*)))
(if (null? m*)
m
(iter (Seq2 m (car m*))
(cdr m*))))))
(define (List . m*)
(let ((m (apply Seq m*)))
(lambda (x* dict succ fail)
(if (null? x*)
(fail)
(let ((x (car x*))
(x* (cdr x*)))
(if (or (null? x) (pair? x))
(m x dict
(lambda (rest dict fail)
(if (null? rest)
(succ x* dict fail)
(fail)))
fail)
(fail)))))))
(define (Seg-var id)
(lambda (x* dict succ fail)
(let ((bd (lookup id dict)))
(if bd
(let ((y* (bd-val bd)))
(let iter ((y* y*) (x* x*))
(cond ((null? y*) (succ x* dict fail))
((null? x*) (fail))
((equal? (car y*) (car x*))
(iter (cdr y*) (cdr x*)))
(else (fail)))))
(let iter ((y* '()) (x* x*))
(succ x* (ext-dict id y* dict)
(lambda ()
(if (null? x*)
(fail)
(iter (attach y* (car x*))
(cdr x*))))))))))
(define (attach l x)
(append l (list x)))
;<pattern> ::= <const>
; | <var>
; | (list <pat>*)
;<pat> ::= <const>
; | <var>
; | <seg-var>
; | (list <pat>*)
(define (compile-pattern p)
(define (Pattern p)
(if (const? p)
(Const p)
(case (car p)
((?) (Var (var-id p)))
((list)
(apply List (map Pat (cdr p)))))))
(define (Pat p)
(if (const? p)
(Const p)
(case (car p)
((?) (Var (var-id p)))
((??) (Seg-var (var-id p)))
((list)
(apply List (map Pat (cdr p)))))))
(Pattern p))(define (vector-copy v)
(define l (vector-length v))
(define u (make-vector l))
(let iter ((i 0))
(if (= i l)
u
(begin
(vector-set! u i (vector-ref v i))
(iter (+ i 1))))))
(define (vector-swap! v i j)
(define t (vector-ref v i))
(vector-set! v i (vector-ref v j))
(vector-set! v j t))
(define (build-vector l p)
(define v (make-vector l))
(let iter ((i 0))
(if (= i l)
v
(begin
(vector-set! v i (p i))
(iter (+ i 1))))))
(define (vector-map p v)
(define l (vector-length v))
(define u (make-vector l))
(let iter ((i 0))
(if (= i l)
u
(begin
(vector-set! u i (p (vector-ref v i)))
(iter (+ i 1))))))
(define (vector-map! p v)
(define l (vector-length v))
(let iter ((i 0))
(unless (= i l)
(vector-set! v i (p (vector-ref v i)))
(iter (+ i 1)))))
(define (vector-for-each p v)
(define l (vector-length v))
(let iter ((i 0))
(unless (= i l)
(p (vector-ref v i))
(iter (+ i 1)))))