fixed higher-order function contracts in intermediate

svn: r1489
This commit is contained in:
Matthias Felleisen 2005-12-02 15:11:23 +00:00
parent 55037c44cf
commit 2526db5610
3 changed files with 173 additions and 141 deletions

View File

@ -46,13 +46,13 @@
"to apply a function to each item on one or more lists for effect only") "to apply a function to each item on one or more lists for effect only")
(filter ((X -> boolean) (listof X) -> (listof X)) (filter ((X -> boolean) (listof X) -> (listof X))
"to construct a list from all those items on a list for which the predicate holds") "to construct a list from all those items on a list for which the predicate holds")
(foldr ((X Y -> Y) Y (listof X) -> Y) ((intermediate-foldr foldr) ((X Y -> Y) Y (listof X) -> Y)
"(foldr f base (list x-1 ... x-n)) = (f x-1 ... (f x-n base))") "(foldr f base (list x-1 ... x-n)) = (f x-1 ... (f x-n base))")
(foldl ((X Y -> Y) Y (listof X) -> Y) ((intermediate-foldl foldl) ((X Y -> Y) Y (listof X) -> Y)
"(foldl f base (list x-1 ... x-n)) = (f x-n ... (f x-1 base))") "(foldl f base (list x-1 ... x-n)) = (f x-n ... (f x-1 base))")
(build-list (nat (nat -> X) -> (listof X)) (build-list (nat (nat -> X) -> (listof X))
"(build-list n f) = (list (f 0) ... (f (- n 1)))") "(build-list n f) = (list (f 0) ... (f (- n 1)))")
(build-string (nat (nat -> char) -> string) ((intermediate-build-string build-string) (nat (nat -> char) -> string)
"(build-string n f) = (string (f 0) ... (f (- n 1)))") "(build-string n f) = (string (f 0) ... (f (- n 1)))")
((intermediate-quicksort quicksort) ((listof X) (X X -> boolean) -> (listof X)) ((intermediate-quicksort quicksort) ((listof X) (X X -> boolean) -> (listof X))
"to construct a list from all items on a list in an order according to a predicate") "to construct a list from all items on a list in an order according to a predicate")
@ -63,9 +63,6 @@
(memf ((X -> boolean) (listof X) -> (union false (listof X))) (memf ((X -> boolean) (listof X) -> (union false (listof X)))
"to determine whether the first argument produces true for some value in the second argument") "to determine whether the first argument produces true for some value in the second argument")
(assf ((X -> boolean) (listof (cons X Y)) -> (union false (cons X Y)))
"to determine whether the first argument produces true for some value in the second argument")
(apply ((X-1 ... X-N -> Y) X-1 ... X-i (list X-i+1 ... X-N) -> Y) (apply ((X-1 ... X-N -> Y) X-1 ... X-i (list X-i+1 ... X-N) -> Y)
"to apply a function using items from a list as the arguments") "to apply a function using items from a list as the arguments")
(compose ((Y-1 -> Z) ... (Y-N -> Y-N-1) (X-1 ... X-N -> Y-N) -> (X-1 ... X-N -> Z)) (compose ((Y-1 -> Z) ... (Y-N -> Y-N-1) (X-1 ... X-N -> Y-N) -> (X-1 ... X-N -> Z))

View File

@ -365,6 +365,8 @@
"to determine whether a value is a string") "to determine whether a value is a string")
(string-length (string -> nat) (string-length (string -> nat)
"to determine the length of a string") "to determine the length of a string")
(string (char ... -> string)
"(string c1 c2 ...) builds a string")
(make-string (nat char -> string) (make-string (nat char -> string)
"to produce a string of given length" "to produce a string of given length"
"from a single given character") "from a single given character")

View File

@ -2,7 +2,8 @@
(module teachprims mzscheme (module teachprims mzscheme
(require "../imageeq.ss" (require "../imageeq.ss"
(lib "list.ss")) (lib "list.ss")
(lib "etc.ss"))
(define-syntax (define-teach stx) (define-syntax (define-teach stx)
(syntax-case stx () (syntax-case stx ()
@ -248,24 +249,53 @@
(check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real) (check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real)
(tequal? a b c))) (tequal? a b c)))
(define (qcheck fmt-str x) (define (qcheck quicksort fmt-str . x)
(raise (raise
(make-exn:fail:contract (make-exn:fail:contract
(string->immutable-string (string->immutable-string
(string-append "quicksort: " (format fmt-str x))) (string-append (format "~a : " quicksort) (apply format fmt-str x)))
(current-continuation-marks)))) (current-continuation-marks))))
(define-teach intermediate quicksort (define-teach intermediate quicksort
(lambda (l cmp?) (lambda (l cmp?)
(unless (beginner-list? l) (unless (beginner-list? l)
(qcheck "first argument must be of type <list>, given ~e" l)) (qcheck 'quicksort "first argument must be of type <list>, given ~e" l))
(unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2)) (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2))
(qcheck "second argument must be a <procedure> that accepts two arguments, given ~e" cmp?)) (qcheck 'quicksort "second argument must be a <procedure> that accepts two arguments, given ~e" cmp?))
(quicksort l (lambda (x y) (quicksort l (lambda (x y)
(define r (cmp? x y)) (define r (cmp? x y))
(unless (boolean? r) (unless (boolean? r)
(qcheck "the results of the procedure argument must be of type <boolean>, produced ~e" r)) (qcheck 'quicksort "the results of the procedure argument must be of type <boolean>, produced ~e" r))
r)))) r))))
(define-teach intermediate foldr
(lambda (f e l)
(unless (and (procedure? f) (procedure-arity-includes? f 2))
(qcheck 'foldr "first argument must be a <procedure> that accepts two arguments, given ~e" f))
(unless (beginner-list? l)
(qcheck 'foldr "third argument must be of type <list>, given ~e" l))
(foldr f e l)))
(define-teach intermediate foldl
(lambda (f e l)
(unless (and (procedure? f) (procedure-arity-includes? f 2))
(qcheck 'foldl "first argument must be a <procedure> that accepts two arguments, given ~e" f))
(unless (beginner-list? l)
(qcheck 'foldl "third argument must be of type <list>, given ~e" l))
(foldl f e l)))
(define-teach intermediate build-string
(lambda (n f)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(qcheck 'build-string "second argument must be a <procedure> that accepts one argument, given ~e" f))
(unless (and (number? n) (integer? n) (>= n 0))
(qcheck 'build-string "first argument must be of type <natural number>, given ~e" n))
(build-string n (lambda (i)
(define r (f i))
(unless (char? r)
(qcheck 'build-string "second argument must be a <procedure> that produces a <char>, given ~e which produced ~e for ~e" f r i))
r))))
(define-teach advanced cons (define-teach advanced cons
(lambda (a b) (lambda (a b)
@ -313,6 +343,9 @@
beginner-equal~? beginner-equal~?
beginner-=~ beginner-=~
intermediate-quicksort intermediate-quicksort
intermediate-foldr
intermediate-foldl
intermediate-build-string
advanced-cons advanced-cons
advanced-set-cdr! advanced-set-cdr!
advanced-set-rest! advanced-set-rest!