Checked R7RS Scheme source for Lesson 2.
(import (scheme base)
(scheme write)
(scheme process-context))
(define failures '())
(define (record-failure label expected actual)
(set! failures (cons (list label expected actual) failures)))
(define (check-equal label expected actual)
(unless (equal? expected actual)
(record-failure label expected actual)))
(define (check-true label value)
(unless value
(record-failure label #t value)))
(define (check-close label expected actual tolerance)
(unless (< (abs (- expected actual)) tolerance)
(record-failure label expected actual)))
(define pi-approx 3.141592654)
(define square-factor 1)
(define circle-factor pi-approx)
(define sphere-factor (* 4 pi-approx))
(define hexagon-factor (* (sqrt 3) 1.5))
(define (area shape-factor r)
(* shape-factor r r))
(check-equal 'square-area 25 (area square-factor 5))
(check-close 'circle-area 78.53981635 (area circle-factor 5) 0.000001)
(check-close 'sphere-area 314.1592654 (area sphere-factor 5) 0.000001)
(check-close 'hexagon-area 64.95190528 (area hexagon-factor 5) 0.000001)
(define (square-number n)
(* n n))
(define (cube-number n)
(* n n n))
(check-true 'procedure-value (procedure? square-number))
(check-true 'quoted-name-is-symbol (symbol? 'square-number))
(define (sum-from-to term a b)
(if (> a b)
0
(+ (term a)
(sum-from-to term (+ a 1) b))))
(check-equal 'sum-squares 55 (sum-from-to square-number 1 5))
(check-equal 'sum-cubes 100 (sum-from-to cube-number 1 4))
(check-equal 'lambda-sum 100 (sum-from-to (lambda (x) (* x x x)) 1 4))
(check-equal 'empty-range 0 (sum-from-to square-number 5 4))
(define (filter-list pred items)
(cond
((null? items) '())
((pred (car items))
(cons (car items)
(filter-list pred (cdr items))))
(else
(filter-list pred (cdr items)))))
(check-equal 'filter-even '(2 4 6) (filter-list even? '(1 2 3 4 5 6)))
(check-equal 'filter-symbols '(scheme r7rs)
(filter-list symbol? '(scheme 7 r7rs "text")))
(check-equal 'filter-lambda '(12 15)
(filter-list (lambda (n) (> n 10)) '(4 12 8 15)))
(define (make-adder n)
(lambda (x)
(+ x n)))
(define add-ten (make-adder 10))
(check-equal 'make-adder-bound 17 (add-ten 7))
(check-equal 'make-adder-direct 123 ((make-adder 100) 23))
(define (compose f g)
(lambda (x)
(f (g x))))
(define (add-one n)
(+ n 1))
(define (twice f)
(compose f f))
(check-equal 'compose 25 ((compose square-number add-one) 4))
(check-equal 'twice 16 ((twice square-number) 2))
(define (quadratic-roots a b c)
(let ((d (sqrt (- (* b b) (* 4 a c))))
(minus-b (- b))
(two-a (* 2 a)))
(list (/ (+ minus-b d) two-a)
(/ (- minus-b d) two-a))))
(define roots (quadratic-roots 1 -3 2))
(check-close 'quadratic-root-one 2 (car roots) 0.000001)
(check-close 'quadratic-root-two 1 (cadr roots) 0.000001)
(define x 5)
(check-equal 'let-bindings-see-outer-environment
6
(let ((x 10)
(y (+ x 1)))
y))
(check-equal 'let-as-lambda
(let ((d 10))
(+ d d))
((lambda (d)
(+ d d))
10))
(if (null? failures)
(begin
(display "Intro lesson 02 tests passed")
(newline)
(exit 0))
(begin
(display "Intro lesson 02 tests failed")
(newline)
(for-each (lambda (failure)
(write failure)
(newline))
(reverse failures))
(exit 1)))