andmap, ormap (10326); remove added

svn: r15555

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 <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 '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) #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"))
+
+|#

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

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)
+    ((intermediate-andmap andmap) ((X -> boolean) (listof X) -> boolean)
-	    "(andmap p (list x-1 ... x-n)) = (and (p x-1) (and ... (p x-n)))")
+	    "(andmap p (list x-1 ... x-n)) = (and (p x-1) ... (p x-n))")
-    (ormap ((X -> boolean) (listof X) -> boolean)
+    ((intermediate-ormap ormap) ((X -> boolean) (listof X) -> boolean)
-	   "(ormap p (list x-1 ... x-n)) = (or (p x-1) (or ... (p x-n)))")
+	   "(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")

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 <list>, given ~e" l))
+    (hocheck name "first argument must be of type <list>, given ~e" l))
   (unless (and (procedure? cmp?) (procedure-arity-includes? cmp? 2))
-    (qcheck name "second argument must be a <procedure> that accepts two arguments, given ~e" cmp?))
+    (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)
-              (qcheck name "the results of the procedure argument must be of type <boolean>, produced ~e" r))
+              (hocheck name "the results of the procedure argument must be of type <boolean>, 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 <procedure> that accepts two arguments, given ~e" f))
+      (hocheck '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))
+      (hocheck '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))
+      (hocheck '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))
+      (hocheck '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))
+      (hocheck '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))
+      (hocheck '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
+                        (hocheck 'build-string
                                 "second argument must be a <procedure> that produces a <char>, 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