From 5e638cc8fe95838d7102f55d0379e23a3b8e1764 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 24 Jul 2009 22:06:24 +0000 Subject: [PATCH] andmap, ormap (10326); remove added svn: r15555 --- collects/lang/private/and-or-map.ss | 54 ++++++++++++++++++++++ collects/lang/private/beginner-funs.ss | 5 +- collects/lang/private/intermediate-funs.ss | 10 ++-- collects/lang/private/teachprims.ss | 34 +++++++++----- 4 files changed, 85 insertions(+), 18 deletions(-) create mode 100644 collects/lang/private/and-or-map.ss diff --git a/collects/lang/private/and-or-map.ss b/collects/lang/private/and-or-map.ss new file mode 100644 index 0000000000..03163fd15b --- /dev/null +++ b/collects/lang/private/and-or-map.ss @@ -0,0 +1,54 @@ +#lang scheme + +(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 '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) #f (beginner-or (f (car l)) (loop (cdr l))))))) + + +#| TESTS + +(with-handlers ((exn:fail:contract? void)) + (intermediate-ormap cons '(1 2 3))) + +(with-handlers ((exn:fail:contract? void)) + (intermediate-andmap cons '(1 2 3))) + +(with-handlers ((exn:fail:contract? void)) + (intermediate-ormap add1 1)) + +(with-handlers ((exn:fail:contract? void)) + (intermediate-andmap add1 1)) + +(with-handlers ((exn:fail:contract? void)) + (intermediate-ormap (lambda (x) x) '(1 2 3))) + +(with-handlers ((exn:fail:contract? void)) + (intermediate-andmap (lambda (x) x) '(1 2 3))) + +(with-handlers ((exn:fail:contract? void)) + (intermediate-andmap add1 '(1 2 3))) + +(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")) + +|# \ No newline at end of file diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index 413f231a8b..d946848c97 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -291,9 +291,12 @@ (memv (any (listof any) -> (union false list)) "to determine whether some value is on the list" " (comparing values with eqv?)") - ((beginner-member member) (any (listof any)-> boolean) + ((beginner-member member) (any (listof any) -> boolean) "to determine whether some value is on the list" " (comparing values with equal?)") + ((beginner-remove remove) (any (listof any) -> (listof any)) + "to construct a list like the given one with the first occurrence of the given item removed" + " (comparing values with equal?)") (reverse ((listof any) -> list) "to create a reversed version of a list") (assq (X (listof (cons X Y)) -> (union false (cons X Y))) diff --git a/collects/lang/private/intermediate-funs.ss b/collects/lang/private/intermediate-funs.ss index 31dc926ca0..90619a9983 100644 --- a/collects/lang/private/intermediate-funs.ss +++ b/collects/lang/private/intermediate-funs.ss @@ -1,5 +1,5 @@ (module intermediate-funs scheme/base - (require "teachprims.ss" + (require "teachprims.ss" "and-or-map.ss" mzlib/etc scheme/list syntax/docprovide @@ -36,10 +36,10 @@ "to construct a list from all items on a list in an order according to a predicate") ((intermediate-sort sort) ((listof X) (X X -> boolean) -> (listof X)) "to construct a list from all items on a list in an order according to a predicate") - (andmap ((X -> boolean) (listof X) -> boolean) - "(andmap p (list x-1 ... x-n)) = (and (p x-1) (and ... (p x-n)))") - (ormap ((X -> boolean) (listof X) -> boolean) - "(ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))") + ((intermediate-andmap andmap) ((X -> boolean) (listof X) -> boolean) + "(andmap p (list x-1 ... x-n)) = (and (p x-1) ... (p x-n))") + ((intermediate-ormap ormap) ((X -> boolean) (listof X) -> boolean) + "(ormap p (list x-1 ... x-n)) = (or (p x-1) ... (p x-n))") (argmin ((X -> real) (listof X) -> X) "to find the (first) element of the list that minimizes the output of the function") diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 74607739af..e04f49c71d 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -32,6 +32,8 @@ namespace. (let ([id expr]) id))))])) +(provide define-teach) + (define-teach beginner list? (lambda (x) (or (null? x) (pair? x)))) @@ -161,6 +163,11 @@ namespace. (check-second 'member a b) (not (boolean? (member a b))))) +(define-teach beginner remove + (lambda (a b) + (check-second 'remove a b) + (remove a b))) + (define-teach beginner cons (lambda (a b) (check-second 'cons a b) @@ -249,21 +256,23 @@ namespace. (check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real) (tequal? a b c))) -(define (qcheck quicksort fmt-str . x) +(define (hocheck name fmt-str . x) (raise (make-exn:fail:contract - (string-append (format "~a : " quicksort) (apply format fmt-str x)) + (string-append (format "~a : " name) (apply format fmt-str x)) (current-continuation-marks)))) +(provide hocheck) + (define (do-sort l cmp? name) (unless (beginner-list? l) - (qcheck name "first argument must be of type , given ~e" l)) + (hocheck name "first argument must be of type , given ~e" l)) (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2)) - (qcheck name "second argument must be a that accepts two arguments, given ~e" cmp?)) + (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) - (qcheck name "the results of the procedure argument must be of type , produced ~e" r)) + (hocheck name "the results of the procedure argument must be of type , produced ~e" r)) r))) (define-teach intermediate quicksort @@ -276,29 +285,29 @@ namespace. (define-teach intermediate foldr (lambda (f e l) (unless (and (procedure? f) (procedure-arity-includes? f 2)) - (qcheck 'foldr "first argument must be a that accepts two arguments, given ~e" f)) + (hocheck 'foldr "first argument must be a that accepts two arguments, given ~e" f)) (unless (beginner-list? l) - (qcheck 'foldr "third argument must be of type , given ~e" l)) + (hocheck 'foldr "third argument must be of type , 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 that accepts two arguments, given ~e" f)) + (hocheck 'foldl "first argument must be a that accepts two arguments, given ~e" f)) (unless (beginner-list? l) - (qcheck 'foldl "third argument must be of type , given ~e" l)) + (hocheck 'foldl "third argument must be of type , 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 that accepts one argument, given ~e" f)) + (hocheck 'build-string "second argument must be a that accepts one argument, given ~e" f)) (unless (and (number? n) (integer? n) (>= n 0)) - (qcheck 'build-string "first argument must be of type , given ~e" n)) + (hocheck 'build-string "first argument must be of type , given ~e" n)) (build-string n (lambda (i) (define r (f i)) (unless (char? r) - (qcheck 'build-string + (hocheck 'build-string "second argument must be a that produces a , given ~e, which produced ~e for ~e" f r i)) r)))) @@ -329,6 +338,7 @@ namespace. beginner-sqr beginner-list? beginner-member + beginner-remove beginner-cons beginner-list* beginner-append