Checked R7RS Scheme source for Lesson 5.
(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 (make-tree datum children)
(cons datum children))
(define (datum node)
(car node))
(define (children node)
(cdr node))
(define (leaf? node)
(null? (children node)))
(define lisbon-tree (make-tree 'lisbon '()))
(define porto-tree (make-tree 'porto '()))
(define portugal-tree (make-tree 'portugal (list lisbon-tree porto-tree)))
(define europe-tree (make-tree 'europe (list portugal-tree)))
(define nairobi-tree (make-tree 'nairobi '()))
(define kenya-tree (make-tree 'kenya (list nairobi-tree)))
(define africa-tree (make-tree 'africa (list kenya-tree)))
(define geography-tree (make-tree 'world (list europe-tree africa-tree)))
(check-equal 'root-datum 'world (datum geography-tree))
(check-equal 'first-child-datum 'europe (datum (car (children geography-tree))))
(check-true 'lisbon-leaf (leaf? lisbon-tree))
(check-true 'portugal-not-leaf (not (leaf? portugal-tree)))
(check-equal 'europe-subtree 'europe (datum europe-tree))
(check-equal 'europe-child-count 1 (length (children europe-tree)))
(define (tree-map proc tree)
(make-tree (proc (datum tree))
(map (lambda (child)
(tree-map proc child))
(children tree))))
(define number-tree
(make-tree 1
(list (make-tree 2 '())
(make-tree 3
(list (make-tree 4 '()))))))
(define squared-number-tree
(make-tree 1
(list (make-tree 4 '())
(make-tree 9
(list (make-tree 16 '()))))))
(check-equal 'tree-map-square squared-number-tree
(tree-map (lambda (n) (* n n)) number-tree))
(check-equal 'tree-map-symbols
(make-tree 'seen
(list (make-tree 'seen '())
(make-tree 'seen
(list (make-tree 'seen '())))))
(tree-map (lambda (value) 'seen) number-tree))
(define (nested-tree-map proc tree)
(cond
((null? tree) '())
((pair? tree)
(cons (nested-tree-map proc (car tree))
(nested-tree-map proc (cdr tree))))
(else (proc tree))))
(check-equal 'nested-square
'(1 (4 9) (16 (25 36) 49))
(nested-tree-map (lambda (n) (* n n))
'(1 (2 3) (4 (5 6) 7))))
(check-equal 'nested-symbols
'(x (x x) x)
(nested-tree-map (lambda (value) 'x)
'(a (b c) d)))
(check-equal 'nested-empty '()
(nested-tree-map (lambda (value) 'x) '()))
(define (leaf-count tree)
(if (leaf? tree)
1
(apply + (map leaf-count (children tree)))))
(check-equal 'leaf-count-geography 3 (leaf-count geography-tree))
(check-equal 'leaf-count-single 1 (leaf-count lisbon-tree))
(if (null? failures)
(begin
(display "Intro lesson 05 tests passed")
(newline)
(exit 0))
(begin
(display "Intro lesson 05 tests failed")
(newline)
(for-each (lambda (failure)
(write failure)
(newline))
(reverse failures))
(exit 1)))