fixed higher-order function contracts in intermediate

svn: r1489

collects/lang/htdp-intermediate.ss

@@ -46,13 +46,13 @@
 	      "to apply a function to each item on one or more lists for effect only")
     (filter ((X -> boolean) (listof X) -> (listof X))
 	    "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))")
-    (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))")
     (build-list (nat (nat -> X) -> (listof X))
 		"(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)))")
     ((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")
@@ -63,9 +63,6 @@
 
     (memf ((X -> boolean) (listof X) -> (union false (listof X)))
 	  "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)
 	      "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/beginner-funs.ss

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

collects/lang/private/teachprims.ss

@@ -2,7 +2,8 @@
 (module teachprims mzscheme
 
   (require "../imageeq.ss" 
-           (lib "list.ss"))
+    (lib "list.ss")
+    (lib "etc.ss"))
   
   (define-syntax (define-teach stx)
     (syntax-case stx ()
@@ -248,24 +249,53 @@
       (check-three a b c 'equal~? values 'any values 'any positive-real? 'non-negative-real)
       (tequal? a b c)))
 
-  (define (qcheck fmt-str x)
+  (define (qcheck quicksort fmt-str . x)
     (raise
       (make-exn:fail:contract
 	(string->immutable-string
-       (string-append "quicksort: " (format fmt-str x)))
+	  (string-append (format "~a : " quicksort) (apply format fmt-str x)))
 	(current-continuation-marks))))
     
   (define-teach intermediate quicksort
     (lambda (l cmp?)
       (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))
-        (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) 
                      (define r (cmp? x y))
                      (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))))
+  (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 
     (lambda (a b)
@@ -313,6 +343,9 @@
     beginner-equal~?
     beginner-=~
     intermediate-quicksort
+    intermediate-foldr
+    intermediate-foldl
+    intermediate-build-string
     advanced-cons
     advanced-set-cdr!
     advanced-set-rest!