323 lines
7.9 KiB
Scheme
323 lines
7.9 KiB
Scheme
|
|
(module teachprims mzscheme
|
|
|
|
(require "../imageeq.ss"
|
|
(lib "list.ss"))
|
|
|
|
(define-syntax (define-teach stx)
|
|
(syntax-case stx ()
|
|
[(_ level id expr)
|
|
(with-syntax ([level-id (datum->syntax-object
|
|
(syntax id)
|
|
(string->symbol
|
|
(format "~a-~a"
|
|
(syntax-object->datum (syntax level))
|
|
(syntax-object->datum (syntax id))))
|
|
(syntax id))])
|
|
(syntax (define level-id
|
|
(let ([id expr])
|
|
id))))]))
|
|
|
|
(define-teach beginner list?
|
|
(lambda (x)
|
|
(or (null? x) (pair? x))))
|
|
|
|
;; Don't need this anymore, since we just check for pairs:
|
|
#;
|
|
(define cyclic-list?
|
|
(lambda (l)
|
|
(or (list? l)
|
|
(and (pair? l)
|
|
(let loop ([hare (cdr l)][turtle l])
|
|
(cond
|
|
[(eq? hare turtle) #t]
|
|
[(not (pair? hare)) #f]
|
|
[(eq? (cdr hare) turtle) #t]
|
|
[(not (pair? (cdr hare))) #f]
|
|
[else (loop (cddr hare) (cdr turtle))]))))))
|
|
|
|
(define cyclic-list? beginner-list?)
|
|
|
|
(define (build-arg-list args)
|
|
(let loop ([args args][n 0])
|
|
(cond
|
|
[(null? args) ""]
|
|
[(= n 5) " ..."]
|
|
[else
|
|
(format " ~e~a" (car args) (loop (cdr args) (add1 n)))])))
|
|
|
|
(define (mk-check-second ok? type)
|
|
(lambda (prim-name a b)
|
|
(unless (ok? b)
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(string->immutable-string
|
|
(format "~a: second argument must be of type <~a>, given ~e and ~e"
|
|
prim-name type
|
|
a b))
|
|
(current-continuation-marks))))))
|
|
|
|
(define check-second
|
|
(mk-check-second beginner-list? "list"))
|
|
|
|
(define check-second/cycle
|
|
(mk-check-second cyclic-list? "list or cyclic list"))
|
|
|
|
(define (mk-check-last ok? type)
|
|
(lambda (prim-name args)
|
|
(let loop ([l args])
|
|
(cond
|
|
[(null? l) (void)]
|
|
[(null? (cdr l))
|
|
(let ([last (car l)])
|
|
(unless (ok? last)
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(string->immutable-string
|
|
(format "~a: last argument must be of type <~a>, given ~e; other args:~a"
|
|
prim-name type
|
|
last
|
|
(build-arg-list
|
|
(let loop ([args args])
|
|
(cond
|
|
[(null? (cdr args)) null]
|
|
[else (cons (car args) (loop (cdr args)))])))))
|
|
(current-continuation-marks)))))]
|
|
[else (loop (cdr l))]))))
|
|
|
|
(define check-last
|
|
(mk-check-last beginner-list? "list"))
|
|
|
|
(define check-last/cycle
|
|
(mk-check-last cyclic-list? "list or cyclic list"))
|
|
|
|
(define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type)
|
|
(let ([bad
|
|
(lambda (v which type)
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(string->immutable-string
|
|
(format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e"
|
|
prim-name which type
|
|
a b c))
|
|
(current-continuation-marks))))])
|
|
(unless (ok1? a)
|
|
(bad a "first" 1type))
|
|
(unless (ok2? b)
|
|
(bad b "second" 2type))
|
|
(unless (ok3? c)
|
|
(bad c "second" 3type))))
|
|
|
|
(define (positive-real? v)
|
|
(and (real? v) (>= v 0)))
|
|
|
|
(define-teach beginner not
|
|
(lambda (a)
|
|
(unless (boolean? a)
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(string->immutable-string
|
|
(format "not: expected either true or false; given ~e"
|
|
a))
|
|
(current-continuation-marks))))
|
|
(not a)))
|
|
|
|
(define-teach beginner +
|
|
(lambda (a b . args)
|
|
(apply + a b args)))
|
|
|
|
(define-teach beginner /
|
|
(lambda (a b . args)
|
|
(apply / a b args)))
|
|
|
|
(define-teach beginner *
|
|
(lambda (a b . args)
|
|
(apply * a b args)))
|
|
|
|
(define-teach beginner member
|
|
(lambda (a b)
|
|
(check-second 'member a b)
|
|
(not (boolean? (member a b)))))
|
|
|
|
(define-teach beginner cons
|
|
(lambda (a b)
|
|
(check-second 'cons a b)
|
|
(cons a b)))
|
|
|
|
(define-teach beginner list*
|
|
(lambda x
|
|
(check-last 'list* x)
|
|
(apply list* x)))
|
|
|
|
(define-teach beginner append
|
|
(lambda x
|
|
(check-last 'append x)
|
|
(apply append x)))
|
|
|
|
(define-teach beginner error
|
|
(lambda (sym str)
|
|
(unless (and (symbol? sym)
|
|
(string? str))
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(string->immutable-string
|
|
(format "error: expected a symbol and a string, got ~e and ~e"
|
|
sym str))
|
|
(current-continuation-marks))))
|
|
(error sym "~a" str)))
|
|
|
|
(define-teach beginner struct?
|
|
(lambda (x)
|
|
(not (or (number? x)
|
|
(boolean? x)
|
|
(pair? x)
|
|
(symbol? x)
|
|
(string? x)
|
|
(procedure? x)
|
|
(vector? x)
|
|
(char? x)
|
|
(port? x)
|
|
(eof-object? x)
|
|
(void? x)))))
|
|
|
|
(define-teach beginner exit
|
|
(lambda () (exit)))
|
|
|
|
;; This equality predicate doesn't handle hash tables.
|
|
;; (It could, but there are no hash tables in the teaching
|
|
;; languages.)
|
|
(define (tequal? a b epsilon)
|
|
(let ? ([a a][b b])
|
|
(or (equal? a b)
|
|
(cond
|
|
[(box? a)
|
|
(and (box? b)
|
|
(? (unbox a) (unbox b)))]
|
|
[(pair? a)
|
|
(and (pair? b)
|
|
(? (car a) (car b))
|
|
(? (cdr a) (cdr b)))]
|
|
[(vector? a)
|
|
(and (vector? b)
|
|
(= (vector-length a) (vector-length b))
|
|
(andmap ?
|
|
(vector->list a)
|
|
(vector->list b)))]
|
|
[(image? a)
|
|
(and (image? b)
|
|
(image=? a b))]
|
|
[(real? a)
|
|
(and epsilon
|
|
(real? b)
|
|
(beginner-=~ a b epsilon))]
|
|
[(struct? a)
|
|
(and (struct? b)
|
|
(let-values ([(ta sa?) (struct-info a)]
|
|
[(tb sb?) (struct-info b)])
|
|
(and (not sa?)
|
|
(not sb?)
|
|
(eq? ta tb)
|
|
(? (struct->vector a)
|
|
(struct->vector b)))))]
|
|
[(hash-table? a)
|
|
(and (hash-table? b)
|
|
(eq? (immutable? a) (immutable? b))
|
|
(eq? (hash-table? a 'weak) (hash-table? b 'weak))
|
|
(eq? (hash-table? a 'equal) (hash-table? b 'equal))
|
|
(let ([al (hash-table-map a cons)]
|
|
[bl (hash-table-map b cons)])
|
|
(and (= (length al) (length bl))
|
|
(for-each
|
|
(lambda (ai)
|
|
(? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
|
|
(cdr ai)))
|
|
al))))]
|
|
[else #f]))))
|
|
|
|
(define-teach beginner equal?
|
|
(lambda (a b)
|
|
(tequal? a b #f)))
|
|
|
|
(define-teach beginner =~
|
|
(lambda (a b c)
|
|
(check-three a b c '=~ real? 'real real? 'real positive-real? 'non-negative-real)
|
|
(<= (- a c) b (+ a c))))
|
|
|
|
(define-teach beginner equal~?
|
|
(lambda (a b c)
|
|
(check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real)
|
|
(tequal? a b c)))
|
|
|
|
(define (qcheck fmt-str x)
|
|
(raise
|
|
(make-exn:fail:contract
|
|
(string->immutable-string
|
|
(string-append "quicksort: " (format fmt-str x)))
|
|
(current-continuation-marks))))
|
|
|
|
(define-teach intermediate quicksort
|
|
(lambda (l cmp?)
|
|
(unless (beginner-list? l)
|
|
(qcheck "first argument must be of type <list>, given ~e" l))
|
|
(unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2))
|
|
(qcheck "second argument must be a <procedure> that accepts two arguments, given ~e" cmp?))
|
|
(quicksort l (lambda (x y)
|
|
(define r (cmp? x y))
|
|
(unless (boolean? r)
|
|
(qcheck "the results of the procedure argument must be of type <boolean>, produced ~e" r))
|
|
r))))
|
|
|
|
(define-teach advanced cons
|
|
(lambda (a b)
|
|
(check-second/cycle 'cons a b)
|
|
(cons a b)))
|
|
|
|
(define-teach advanced set-cdr!
|
|
(lambda (a b)
|
|
(check-second/cycle 'set-cdr! a b)
|
|
(set-cdr! a b)))
|
|
|
|
(define-teach advanced set-rest!
|
|
(lambda (a b)
|
|
(check-second/cycle 'set-rest! a b)
|
|
(set-cdr! a b)))
|
|
|
|
(define-teach advanced list*
|
|
(lambda x
|
|
(check-last/cycle 'list* x)
|
|
(apply list* x)))
|
|
|
|
(define-teach advanced append
|
|
(lambda x
|
|
(check-last/cycle 'append x)
|
|
(apply append x)))
|
|
|
|
(define-teach advanced append!
|
|
(lambda x
|
|
(check-last/cycle 'append! x)
|
|
(apply append! x)))
|
|
|
|
(provide beginner-not
|
|
beginner-+
|
|
beginner-/
|
|
beginner-*
|
|
beginner-list?
|
|
beginner-member
|
|
beginner-cons
|
|
beginner-list*
|
|
beginner-append
|
|
beginner-error
|
|
beginner-struct?
|
|
beginner-exit
|
|
beginner-equal?
|
|
beginner-equal~?
|
|
beginner-=~
|
|
intermediate-quicksort
|
|
advanced-cons
|
|
advanced-set-cdr!
|
|
advanced-set-rest!
|
|
advanced-list*
|
|
advanced-append
|
|
advanced-append!
|
|
cyclic-list?))
|