diff --git a/collects/lang/private/and-or-map.rkt b/collects/lang/private/and-or-map.rkt index 2d79f555c8..3b5165cd71 100644 --- a/collects/lang/private/and-or-map.rkt +++ b/collects/lang/private/and-or-map.rkt @@ -1,54 +1,100 @@ #lang scheme +;; --------------------------------------------------------------------------------------------------- +;; define higher-order primitives that consume boolean-valued functions + (require "teachprims.ss" "teach.ss") -(provide intermediate-andmap intermediate-ormap) - -(define-teach intermediate andmap - (lambda (f l) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (hocheck 'andmap "first argument must be a that accepts one argument, given ~e" f)) - (unless (beginner-list? l) - (hocheck 'andmap "second argument must be of type , given ~e" l)) - (let loop ([l l]) - (if (null? l) #t (beginner-and (f (car l)) (loop (cdr l))))))) - -(define-teach intermediate ormap - (lambda (f l) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (hocheck 'ormap "first argument must be a that accepts one argument, given ~e" f)) - (unless (beginner-list? l) - (hocheck 'ormap "second argument must be of type , given ~e" l)) - (let loop ([l l]) - (if (null? l) #f (beginner-or (f (car l)) (loop (cdr l))))))) +(provide intermediate-andmap intermediate-ormap intermediate-filter + intermediate-quicksort intermediate-sort) -#| TESTS +;; --- checking auxiliaries --- +(define (arity-check t r f a) + (unless (and (procedure? f) (procedure-arity-includes? f a)) + (if (= a 1) + (hocheck t "~a argument must be a that accepts one argument, given ~e" r f) + (hocheck t "~a argument must be a that accepts ~a arguments, given ~e" r a f)))) -(with-handlers ((exn:fail:contract? void)) - (intermediate-ormap cons '(1 2 3))) -(with-handlers ((exn:fail:contract? void)) - (intermediate-andmap cons '(1 2 3))) +(define-syntax-rule + (boolean-test-wrapper tag (f z ...)) + (let () + (define msg (format "the function given to ~a" tag)) + (define *name (object-name f)) + (define name (if *name (format "~a (~a)" *name msg) msg)) + (define (g z ...) + (define f@x (f z ...)) + (if (boolean? f@x) + f@x + (error tag "the results of ~a must be of type , produced ~e" name f@x))) + g)) -(with-handlers ((exn:fail:contract? void)) - (intermediate-ormap add1 1)) +(define (list-check? name msg l) + (unless (beginner-list? l) + (hocheck name "~a argument must be of type , given ~e" msg l))) -(with-handlers ((exn:fail:contract? void)) - (intermediate-andmap add1 1)) +;; --- refined function definitions --- -(with-handlers ((exn:fail:contract? void)) - (intermediate-ormap (lambda (x) x) '(1 2 3))) +(define-syntax-rule + (define-boolean name) + (define-teach intermediate name + (lambda (f l) + (arity-check 'name "first" f 1) + (list-check? 'name "second" l) + (unless (beginner-list? l) + (hocheck 'name "second argument must be of type , given ~e" l)) + (define g (boolean-test-wrapper 'name (f x))) + (name g l)))) -(with-handlers ((exn:fail:contract? void)) - (intermediate-andmap (lambda (x) x) '(1 2 3))) +(define-boolean andmap) +(define-boolean ormap) +(define-boolean filter) -(with-handlers ((exn:fail:contract? void)) - (intermediate-andmap add1 '(1 2 3))) +(define-syntax-rule + (define-sort name) + (define-teach intermediate name + (lambda (l cmp?) + (list-check? 'name "first" l) + (arity-check 'name "second" cmp? 2) + (define dmp? (boolean-test-wrapper 'name (cmp? x y))) + (sort l dmp?)))) + +(define-sort sort) +(define-sort quicksort) + +#| TESTS + +(define (tester tag name) + (lambda (x) + (unless (regexp-match name (exn-message x)) + (displayln '****broken-test****) + (displayln `(,tag ,(exn-message x)))))) + +(define-syntax-rule + (exn-tester label name function inputs ...) + (with-handlers ((exn:fail? (tester label name))) + (function inputs ...) + (error 'exn-tester "***case ~a (~a) failed***" label name))) + +(exn-tester 1 "ormap" intermediate-ormap cons '(1 2 3)) +(exn-tester 2 "andmap" intermediate-andmap cons '(1 2 3)) +(exn-tester 3 "ormap" intermediate-ormap add1 1) +(exn-tester 4 "andmap" intermediate-andmap add1 1) +(exn-tester 5 "ormap" intermediate-ormap (lambda (x) x) '(1 2 3)) +(exn-tester 6 "andmap" intermediate-andmap (lambda (x) x) '(1 2 3)) +(exn-tester 7 "andmap" intermediate-andmap add1 '(1 2 3)) +(exn-tester 8 "filter" intermediate-filter (lambda (x) x) '(1 2 3)) +(exn-tester 9 "filter" intermediate-filter add1 '(1 2 3)) +(exn-tester 10 "sort" intermediate-sort '(1 2 3) (lambda (x y) (if (< x y) y #false))) +(exn-tester 11 "quick" intermediate-quicksort '(1 2 3) (lambda (x y) (if (< x y) y #false))) (unless (equal? (intermediate-ormap odd? '(1 2 3)) #t) (error 'x "1")) (unless (equal? (intermediate-andmap odd? '(1 2 3)) #f) (error 'x "2")) (unless (equal? (intermediate-andmap odd? '(1 3 5)) #t) (error 'x "3")) -(unless (equal? (intermediate-ormap even? '(1 3 5)) #f) (error 'x "1")) - -|# +(unless (equal? (intermediate-ormap even? '(1 3 5)) #f) (error 'x "4")) +(unless (equal? (intermediate-filter odd? '(1 2 3)) '(1 3)) (error 'x "5")) +(unless (equal? (intermediate-filter odd? '()) '()) (error 'x "6")) +(unless (equal? (intermediate-sort '(1 0 2) <) '(0 1 2)) (error 'x "7")) +(unless (equal? (intermediate-quicksort '(1 0 2) <) '(0 1 2)) (error 'x "8")) + |# \ No newline at end of file diff --git a/collects/lang/private/intermediate-funs.rkt b/collects/lang/private/intermediate-funs.rkt index cab07f16bd..9771adbaac 100644 --- a/collects/lang/private/intermediate-funs.rkt +++ b/collects/lang/private/intermediate-funs.rkt @@ -7,8 +7,7 @@ (provide-and-document procedures - (all-from-except beginner: lang/private/beginner-funs procedures - + * - / append) + (all-from-except beginner: lang/private/beginner-funs procedures + * - / append) ("Numbers (relaxed conditions)" @@ -27,7 +26,7 @@ "to construct a new list by applying a function to each item on one or more existing lists") (for-each ((any ... -> any) (listof any) ... -> void) "to apply a function to each item on one or more lists for effect only") - (filter ((X -> boolean) (listof X) -> (listof X)) + ((intermediate-filter filter) ((X -> boolean) (listof X) -> (listof X)) "to construct a list from all those items on a list for which the predicate holds") ((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))") @@ -52,8 +51,8 @@ (argmax ((X -> real) (listof X) -> X) "to find the (first) element of the list that maximizes the output of the function") - (memf ((X -> boolean) (listof X) -> (union false (listof X))) - "to determine whether the first argument produces true for some value in the second argument") + (memf ((X -> any) (listof X) -> (union false (listof X))) + "to determine whether the first argument produces a non-false value for any item in the second argument") (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") (compose ((Y-1 -> Z) ... (Y-N -> Y-N-1) (X-1 ... X-N -> Y-N) -> (X-1 ... X-N -> Z)) diff --git a/collects/lang/private/teachprims.rkt b/collects/lang/private/teachprims.rkt index 3e3df3adba..dc4cf35eef 100644 --- a/collects/lang/private/teachprims.rkt +++ b/collects/lang/private/teachprims.rkt @@ -1,3 +1,5 @@ +#lang scheme + #| tests are at plt/collects/tests/mzscheme/ collects/tests/mzscheme/beginner.ss .../beginner-abbr.ss @@ -9,10 +11,6 @@ Each one has to run separately, since they mangle the top-level namespace. |# -;; MF: switched from -;; module teachprims mzscheme -;; to -#lang scheme (require mzlib/list mzlib/math @@ -334,24 +332,6 @@ namespace. (provide hocheck) -(define (do-sort l cmp? name) - (unless (beginner-list? l) - (hocheck name "first argument must be of type , given ~e" l)) - (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2)) - (hocheck name "second argument must be a that accepts two arguments, given ~e" cmp?)) - (sort l (lambda (x y) - (define r (cmp? x y)) - (unless (boolean? r) - (hocheck name "the results of the procedure argument must be of type , produced ~e" r)) - r))) - -(define-teach intermediate quicksort - (lambda (l cmp?) - (do-sort l cmp? 'quicksort))) -(define-teach intermediate sort - (lambda (l cmp?) - (do-sort l cmp? 'sort))) - (define-teach intermediate foldr (lambda (f e l) (unless (and (procedure? f) (procedure-arity-includes? f 2)) @@ -448,8 +428,6 @@ namespace. beginner-equal? beginner-equal~? beginner-=~ - intermediate-quicksort - intermediate-sort intermediate-foldr intermediate-foldl intermediate-build-string