Checked R7RS Scheme source for Lesson 4.
(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-card rank suit)
(cons rank suit))
(define (card-rank card)
(car card))
(define (card-suit card)
(cdr card))
(define (make-hand . cards)
cards)
(define (first-card hand)
(car hand))
(define (rest-cards hand)
(cdr hand))
(define (hand-total hand)
(if (null? hand)
0
(+ (card-rank (first-card hand))
(hand-total (rest-cards hand)))))
(define sample-hand
(make-hand (make-card 3 'heart)
(make-card 10 'club)
(make-card 4 'diamond)))
(check-equal 'card-rank 10 (card-rank (make-card 10 'heart)))
(check-equal 'card-suit 'heart (card-suit (make-card 10 'heart)))
(check-equal 'first-card (make-card 3 'heart) (first-card sample-hand))
(check-equal 'hand-total 17 (hand-total sample-hand))
(check-equal 'empty-hand-total 0 (hand-total (make-hand)))
(define (make-card-number rank suit)
(cond
((eq? suit 'heart) rank)
((eq? suit 'spade) (+ rank 13))
((eq? suit 'diamond) (+ rank 26))
((eq? suit 'club) (+ rank 39))
(else (error "unknown suit" suit))))
(define (card-number-rank card)
(let ((rank (remainder card 13)))
(if (= rank 0) 13 rank)))
(define (card-number-suit card)
(cond
((<= 1 card 13) 'heart)
((<= 14 card 26) 'spade)
((<= 27 card 39) 'diamond)
((<= 40 card 52) 'club)
(else (error "card out of range" card))))
(check-equal 'card-number-value 30 (make-card-number 4 'diamond))
(check-equal 'card-number-rank 4 (card-number-rank (make-card-number 4 'diamond)))
(check-equal 'card-number-suit 'diamond (card-number-suit (make-card-number 4 'diamond)))
(check-equal 'card-number-king-rank 13 (card-number-rank (make-card-number 13 'club)))
(define (integer-gcd a b)
(if (= b 0)
a
(integer-gcd b (remainder a b))))
(define (make-rat numerator denominator)
(if (= denominator 0)
(error "make-rat: zero denominator")
(let* ((sign (if (< denominator 0) -1 1))
(n (* sign numerator))
(d (* sign denominator))
(g (integer-gcd (abs n) d)))
(cons (/ n g) (/ d g)))))
(define (rat-numerator rat)
(car rat))
(define (rat-denominator rat)
(cdr rat))
(define (rat-add a b)
(make-rat (+ (* (rat-numerator a) (rat-denominator b))
(* (rat-numerator b) (rat-denominator a)))
(* (rat-denominator a) (rat-denominator b))))
(check-equal 'rat-reduce (cons 1 2) (make-rat 4 8))
(check-equal 'rat-sign (cons -1 3) (make-rat 2 -6))
(check-equal 'rat-add (cons 5 6) (rat-add (make-rat 1 2) (make-rat 1 3)))
(define (make-point x y)
(cons x y))
(define (point-x point)
(car point))
(define (point-y point)
(cdr point))
(define (make-segment start end)
(cons start end))
(define (segment-start segment)
(car segment))
(define (segment-end segment)
(cdr segment))
(define (midpoint-segment segment)
(let ((start (segment-start segment))
(end (segment-end segment)))
(make-point (/ (+ (point-x start) (point-x end)) 2)
(/ (+ (point-y start) (point-y end)) 2))))
(define sample-segment
(make-segment (make-point 0 2) (make-point 4 6)))
(check-equal 'point-x 0 (point-x (segment-start sample-segment)))
(check-equal 'point-y 6 (point-y (segment-end sample-segment)))
(check-equal 'midpoint (make-point 2 4) (midpoint-segment sample-segment))
(define (make-interval lower upper)
(if (> lower upper)
(error "make-interval: lower is greater than upper" lower upper)
(cons lower upper)))
(define (interval-lower interval)
(car interval))
(define (interval-upper interval)
(cdr interval))
(define (interval-width interval)
(/ (- (interval-upper interval)
(interval-lower interval))
2))
(check-equal 'interval-lower 3 (interval-lower (make-interval 3 9)))
(check-equal 'interval-upper 9 (interval-upper (make-interval 3 9)))
(check-equal 'interval-width 3 (interval-width (make-interval 3 9)))
(define (functional-cons x y)
(lambda (message)
(cond
((eq? message 'car) x)
((eq? message 'cdr) y)
(else (error "unknown pair message" message)))))
(define (functional-car pair)
(pair 'car))
(define (functional-cdr pair)
(pair 'cdr))
(define functional-pair (functional-cons 'left 'right))
(check-equal 'functional-car 'left (functional-car functional-pair))
(check-equal 'functional-cdr 'right (functional-cdr functional-pair))
(define nested-list '((a b) c (d (e f))))
(check-equal 'nested-first '(a b) (car nested-list))
(check-equal 'nested-second 'c (cadr nested-list))
(check-equal 'nested-third '(d (e f)) (caddr nested-list))
(check-equal 'nested-deep '(e f) (cadr (caddr nested-list)))
(check-true 'nested-proper-list (list? nested-list))
(check-true 'cons-not-proper-list (not (list? (cons 'x 'y))))
(if (null? failures)
(begin
(display "Intro lesson 04 tests passed")
(newline)
(exit 0))
(begin
(display "Intro lesson 04 tests failed")
(newline)
(for-each (lambda (failure)
(write failure)
(newline))
(reverse failures))
(exit 1)))