Checked R7RS Scheme source for Lesson 3.
(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 (square-number n)
(* n n))
(define (square-list numbers)
(if (null? numbers)
'()
(cons (square-number (car numbers))
(square-list (cdr numbers)))))
(check-equal 'square-list '(1 4 9 16 25) (square-list '(1 2 3 4 5)))
(check-equal 'square-list-empty '() (square-list '()))
(define (insert-sorted n sorted)
(cond
((null? sorted) (list n))
((<= n (car sorted)) (cons n sorted))
(else (cons (car sorted)
(insert-sorted n (cdr sorted))))))
(define (insertion-sort numbers)
(if (null? numbers)
'()
(insert-sorted (car numbers)
(insertion-sort (cdr numbers)))))
(check-equal 'insert-empty '(4) (insert-sorted 4 '()))
(check-equal 'insert-front '(1 2 3) (insert-sorted 1 '(2 3)))
(check-equal 'insert-middle '(1 3 4 5) (insert-sorted 4 '(1 3 5)))
(check-equal 'insert-end '(1 3 5 7) (insert-sorted 7 '(1 3 5)))
(check-equal 'insertion-sort '(1 1 3 4 5) (insertion-sort '(5 1 4 1 3)))
(check-equal 'insertion-sort-empty '() (insertion-sort '()))
(define (count-list items)
(if (null? items)
0
(+ 1 (count-list (cdr items)))))
(define (count-list-tail items)
(define (loop rest count)
(if (null? rest)
count
(loop (cdr rest) (+ count 1))))
(loop items 0))
(check-equal 'count-list 5 (count-list '(a b c d e)))
(check-equal 'count-list-tail 5 (count-list-tail '(a b c d e)))
(check-equal 'count-list-tail-empty 0 (count-list-tail '()))
(define (make-range n)
(define (loop i out)
(if (= i 0)
out
(loop (- i 1) (cons i out))))
(loop n '()))
(check-equal 'range-five '(1 2 3 4 5) (make-range 5))
(check-equal 'count-range 100 (count-list-tail (make-range 100)))
(define (square-list-tail numbers)
(define (loop rest out)
(if (null? rest)
(reverse out)
(loop (cdr rest)
(cons (square-number (car rest)) out))))
(loop numbers '()))
(check-equal 'square-list-tail '(1 4 9 16 25)
(square-list-tail '(1 2 3 4 5)))
(define (pascal row col)
(cond
((or (< col 0) (> col row)) 0)
((or (= col 0) (= col row)) 1)
(else (+ (pascal (- row 1) (- col 1))
(pascal (- row 1) col)))))
(check-equal 'pascal-edge 1 (pascal 5 0))
(check-equal 'pascal-middle 6 (pascal 4 2))
(check-equal 'pascal-outside 0 (pascal 4 9))
(define (next-pascal-row row)
(define (loop rest out)
(if (null? (cdr rest))
(reverse (cons 1 out))
(loop (cdr rest)
(cons (+ (car rest) (cadr rest)) out))))
(loop row '(1)))
(define (pascal-row row-number)
(define (loop row index)
(if (= index row-number)
row
(loop (next-pascal-row row) (+ index 1))))
(loop '(1) 0))
(define (pascal-by-row row col)
(list-ref (pascal-row row) col))
(check-equal 'next-pascal-row '(1 3 3 1) (next-pascal-row '(1 2 1)))
(check-equal 'pascal-row-zero '(1) (pascal-row 0))
(check-equal 'pascal-row-five '(1 5 10 10 5 1) (pascal-row 5))
(check-equal 'pascal-by-row 10 (pascal-by-row 5 2))
(check-equal 'pascal-implementations-agree (pascal 5 2) (pascal-by-row 5 2))
(if (null? failures)
(begin
(display "Intro lesson 03 tests passed")
(newline)
(exit 0))
(begin
(display "Intro lesson 03 tests failed")
(newline)
(for-each (lambda (failure)
(write failure)
(newline))
(reverse failures))
(exit 1)))