boolean-valued functions in Intermediate and up now check their results; also fixed some error messages; Closes PR 11745

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 <procedure> that accepts one argument, given ~e" f))
-    (unless (beginner-list? l) 
-      (hocheck 'andmap "second argument must be of type <list>, 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 <procedure> that accepts one argument, given ~e" f))
-    (unless (beginner-list? l) 
-      (hocheck 'ormap "second argument must be of type <list>, 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 <procedure> that accepts one argument, given ~e" r f)
+        (hocheck t "~a argument must be a <procedure> 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 <boolean>, 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 <list>, 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 <list>, 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"))
+ |#

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))

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 <list>, given ~e" l))
-  (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2))
-    (hocheck name "second argument must be a <procedure> 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 <boolean>, 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