Checked R7RS Scheme source for Lesson 1.
(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)))
(check-equal 'arithmetic 6 (+ 1 2 3))
(check-equal 'conditional 'larger (if (> 7 3) 'larger 'smaller))
(define (square-number n)
(* n n))
(check-equal 'procedure-call 81 (square-number 9))
(check-equal 'composed-argument 25 (square-number (+ 2 3)))
(define unit-square-side 1)
(define default-width 7)
(check-equal 'constant-value 1 unit-square-side)
(check-equal 'named-width 7 default-width)
(define (rectangle-area width height)
(* width height))
(define (rectangle-perimeter width height)
(* 2 (+ width height)))
(define (triangle-area base height)
(/ (* base height) 2))
(check-equal 'rectangle-area 42 (rectangle-area 7 6))
(check-equal 'rectangle-perimeter 26 (rectangle-perimeter 7 6))
(check-equal 'triangle-area 12 (triangle-area 8 3))
(define (safe-reciprocal n)
(if (= n 0)
'undefined
(/ 1 n)))
(check-equal 'if-selected-branch 'undefined (safe-reciprocal 0))
(check-equal 'if-other-branch 1/4 (safe-reciprocal 4))
(define (number-kind n)
(cond
((< n 0) 'negative)
((= n 0) 'zero)
((even? n) 'positive-even)
(else 'positive-odd)))
(check-equal 'cond-negative 'negative (number-kind -3))
(check-equal 'cond-zero 'zero (number-kind 0))
(check-equal 'cond-even 'positive-even (number-kind 8))
(check-equal 'cond-odd 'positive-odd (number-kind 9))
(define (buzz-basic n)
(cond
((= (remainder n 7) 0) 'buzz)
((= (remainder n 10) 7) 'buzz)
(else n)))
(check-equal 'buzz-multiple 'buzz (buzz-basic 14))
(check-equal 'buzz-last-digit 'buzz (buzz-basic 27))
(check-equal 'buzz-other 31 (buzz-basic 31))
; Guard before recursion. Without this, negative inputs would keep moving
; farther from the base case and recur forever.
(define (factorial n)
(cond
((or (not (integer? n)) (< n 0))
(error "factorial: expected a nonnegative integer" n))
((<= n 1) 1)
(else (* n (factorial (- n 1))))))
(check-equal 'factorial-zero 1 (factorial 0))
(check-equal 'factorial-one 1 (factorial 1))
(check-equal 'factorial-five 120 (factorial 5))
(define (euclid-gcd a b)
(if (= b 0)
a
(euclid-gcd b (remainder a b))))
(check-equal 'euclid-gcd 6 (euclid-gcd 84 30))
(define sample-words '(scheme r7rs lists))
(check-equal 'first-symbol 'scheme (car sample-words))
(check-true 'list-is-pair (pair? sample-words))
(check-true 'proper-list (list? sample-words))
(check-equal 'list-tail '(r7rs lists) (cdr sample-words))
(define dotted-pair (cons 'left 'right))
(check-true 'dotted-pair-is-pair (pair? dotted-pair))
(check-true 'dotted-pair-is-not-list (not (list? dotted-pair)))
(check-equal 'dotted-pair-car 'left (car dotted-pair))
(check-equal 'dotted-pair-cdr 'right (cdr dotted-pair))
(define (sum-list numbers)
(if (null? numbers)
0
(+ (car numbers) (sum-list (cdr numbers)))))
(check-equal 'structural-recursion 10 (sum-list '(1 2 3 4)))
(define (count-if predicate items)
(cond
((null? items) 0)
((predicate (car items)) (+ 1 (count-if predicate (cdr items))))
(else (count-if predicate (cdr items)))))
(check-equal 'higher-order-procedure
2
(count-if (lambda (n) (> n 5)) '(2 8 4 9)))
(check-equal 'map-square '(1 4 9 16) (map square-number '(1 2 3 4)))
(if (null? failures)
(begin
(display "Intro lesson 01 tests passed")
(newline)
(exit 0))
(begin
(display "Intro lesson 01 tests failed")
(newline)
(for-each (lambda (failure)
(write failure)
(newline))
(reverse failures))
(exit 1)))