fixed higher-order function contracts in intermediate

svn: r1489

collects/lang/htdp-intermediate.ss

@@ -46,14 +46,14 @@
 	      "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)))")
+        "(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")
     (andmap ((X -> boolean) (listof X) -> boolean)
@@ -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,18 +2,19 @@
 (module teachprims mzscheme
 
   (require "../imageeq.ss" 
-           (lib "list.ss"))
+    (lib "list.ss")
+    (lib "etc.ss"))
   
   (define-syntax (define-teach stx)
     (syntax-case stx ()
       [(_ level id expr)
        (with-syntax ([level-id (datum->syntax-object
-				(syntax id)
+				 (syntax id)
-				(string->symbol
+				 (string->symbol
-				 (format "~a-~a"
+				   (format "~a-~a"
-					 (syntax-object->datum (syntax level))
+				     (syntax-object->datum (syntax level))
-					 (syntax-object->datum (syntax id))))
+				     (syntax-object->datum (syntax id))))
-				(syntax id))])
+				 (syntax id))])
 	 (syntax (define level-id
 		   (let ([id expr])
 		     id))))]))
@@ -26,36 +27,36 @@
   #;
   (define cyclic-list?
     (lambda (l)
-       (or (list? l)
+      (or (list? l)
-	   (and (pair? l)
+	  (and (pair? l)
-		(let loop ([hare (cdr l)][turtle l])
+	    (let loop ([hare (cdr l)][turtle l])
-		  (cond
+	      (cond
-		   [(eq? hare turtle) #t]
+		[(eq? hare turtle) #t]
-		   [(not (pair? hare)) #f]
+		[(not (pair? hare)) #f]
-		   [(eq? (cdr hare) turtle) #t]
+		[(eq? (cdr hare) turtle) #t]
-		   [(not (pair? (cdr hare))) #f]
+		[(not (pair? (cdr hare))) #f]
-		   [else (loop (cddr hare) (cdr turtle))]))))))
+		[else (loop (cddr hare) (cdr turtle))]))))))
 
   (define cyclic-list? beginner-list?)
 
   (define (build-arg-list args)
     (let loop ([args args][n 0])
       (cond
-       [(null? args) ""]
+	[(null? args) ""]
-       [(= n 5) " ..."]
+	[(= n 5) " ..."]
-       [else
+	[else
-	(format " ~e~a" (car args) (loop (cdr args) (add1 n)))])))
+	  (format " ~e~a" (car args) (loop (cdr args) (add1 n)))])))
 
   (define (mk-check-second ok? type)
     (lambda (prim-name a b)
       (unless (ok? b)
 	(raise
-	 (make-exn:fail:contract
+	  (make-exn:fail:contract
-	  (string->immutable-string
+	    (string->immutable-string
-	   (format "~a: second argument must be of type <~a>, given ~e and ~e"
+	      (format "~a: second argument must be of type <~a>, given ~e and ~e"
-		   prim-name type
+		prim-name type
-		   a b))
+		a b))
-	  (current-continuation-marks))))))
+	    (current-continuation-marks))))))
 
   (define check-second 
     (mk-check-second beginner-list? "list"))
@@ -67,23 +68,23 @@
     (lambda (prim-name args)
       (let loop ([l args])
 	(cond
-	 [(null? l) (void)]
+	  [(null? l) (void)]
-	 [(null? (cdr l))
+	  [(null? (cdr l))
-	  (let ([last (car l)])
+	   (let ([last (car l)])
-	    (unless (ok? last)
+	     (unless (ok? last)
-	      (raise
+	       (raise
-	       (make-exn:fail:contract
+		 (make-exn:fail:contract
-		(string->immutable-string
+		   (string->immutable-string
-		 (format "~a: last argument must be of type <~a>, given ~e; other args:~a"
+		     (format "~a: last argument must be of type <~a>, given ~e; other args:~a"
-			 prim-name type
+		       prim-name type
-			 last
+		       last
-			 (build-arg-list
+		       (build-arg-list
-			  (let loop ([args args])
+			 (let loop ([args args])
-			    (cond
+			   (cond
 			     [(null? (cdr args)) null]
 			     [else (cons (car args) (loop (cdr args)))])))))
-		(current-continuation-marks)))))]
+		   (current-continuation-marks)))))]
-	 [else (loop (cdr l))]))))
+	  [else (loop (cdr l))]))))
 
   (define check-last 
     (mk-check-last beginner-list? "list"))
@@ -93,14 +94,14 @@
 
   (define (check-three a b c prim-name ok1? 1type ok2? 2type ok3? 3type)
     (let ([bad
-	   (lambda (v which type)
+	    (lambda (v which type)
-	     (raise
+	      (raise
-	      (make-exn:fail:contract
+		(make-exn:fail:contract
-	       (string->immutable-string
+		  (string->immutable-string
-		(format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e"
+		    (format "~a: ~a argument must be of type <~a>, given ~e, ~e, and ~e"
-			prim-name which type
+		      prim-name which type
-			a b c))
+		      a b c))
-	       (current-continuation-marks))))])
+		  (current-continuation-marks))))])
       (unless (ok1? a)
 	(bad a "first" 1type))
       (unless (ok2? b)
@@ -115,11 +116,11 @@
     (lambda (a)
       (unless (boolean? a)
 	(raise
-	 (make-exn:fail:contract
+	  (make-exn:fail:contract
-	  (string->immutable-string
+	    (string->immutable-string
-	   (format "not: expected either true or false; given ~e"
+	      (format "not: expected either true or false; given ~e"
-		   a))
+		a))
-	  (current-continuation-marks))))
+	    (current-continuation-marks))))
       (not a)))
 
   (define-teach beginner +
@@ -157,13 +158,13 @@
   (define-teach beginner error
     (lambda (sym str)
       (unless (and (symbol? sym)
-		   (string? str))
+		(string? str))
 	(raise
-	 (make-exn:fail:contract
+	  (make-exn:fail:contract
-	  (string->immutable-string
+	    (string->immutable-string
-	   (format "error: expected a symbol and a string, got ~e and ~e"
+	      (format "error: expected a symbol and a string, got ~e and ~e"
-		   sym str))
+		sym str))
-	  (current-continuation-marks))))
+	    (current-continuation-marks))))
       (error sym "~a" str)))
 
   (define-teach beginner struct?
@@ -190,49 +191,49 @@
     (let ? ([a a][b b])
       (or (equal? a b)
 	  (cond
-	   [(box? a)
+	    [(box? a)
-	    (and (box? b)
+	     (and (box? b)
-		 (? (unbox a) (unbox b)))]
+	       (? (unbox a) (unbox b)))]
-	   [(pair? a)
+	    [(pair? a)
-	    (and (pair? b)
+	     (and (pair? b)
-		 (? (car a) (car b))
+	       (? (car a) (car b))
-		 (? (cdr a) (cdr b)))]
+	       (? (cdr a) (cdr b)))]
-	   [(vector? a)
+	    [(vector? a)
-	    (and (vector? b)
+	     (and (vector? b)
-		 (= (vector-length a) (vector-length b))
+	       (= (vector-length a) (vector-length b))
-		 (andmap ?
+	       (andmap ?
-			 (vector->list a)
+		 (vector->list a)
-			 (vector->list b)))]
+		 (vector->list b)))]
-	   [(image? a)
+	    [(image? a)
-	    (and (image? b)
+	     (and (image? b)
-		 (image=? a b))]
+	       (image=? a b))]
-	   [(real? a)
+	    [(real? a)
-	    (and epsilon
+	     (and epsilon
-		 (real? b)
+	       (real? b)
-		 (beginner-=~ a b epsilon))]
+	       (beginner-=~ a b epsilon))]
-	   [(struct? a)
+	    [(struct? a)
-	    (and (struct? b)
+	     (and (struct? b)
-		 (let-values ([(ta sa?) (struct-info a)]
+	       (let-values ([(ta sa?) (struct-info a)]
-			      [(tb sb?) (struct-info b)])
+			    [(tb sb?) (struct-info b)])
-		   (and (not sa?)
+		 (and (not sa?)
-			(not sb?)
+		   (not sb?)
-			(eq? ta tb)
+		   (eq? ta tb)
-			(? (struct->vector a)
+		   (? (struct->vector a)
-			   (struct->vector b)))))]
+		      (struct->vector b)))))]
-	   [(hash-table? a)
+	    [(hash-table? a)
-	    (and (hash-table? b)
+	     (and (hash-table? b)
-		 (eq? (immutable? a) (immutable? b))
+	       (eq? (immutable? a) (immutable? b))
-		 (eq? (hash-table? a 'weak) (hash-table? b 'weak))
+	       (eq? (hash-table? a 'weak) (hash-table? b 'weak))
-		 (eq? (hash-table? a 'equal) (hash-table? b 'equal))
+	       (eq? (hash-table? a 'equal) (hash-table? b 'equal))
-		 (let ([al (hash-table-map a cons)]
+	       (let ([al (hash-table-map a cons)]
-		       [bl (hash-table-map b cons)])
+		     [bl (hash-table-map b cons)])
-		   (and (= (length al) (length bl))
+		 (and (= (length al) (length bl))
-			(for-each 
+		   (for-each 
-			 (lambda (ai)
+		     (lambda (ai)
-			   (? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
+		       (? (hash-table-get b (car ai) (lambda () (not (cdr ai))))
-			      (cdr ai)))
+			  (cdr ai)))
-			 al))))]
+		     al))))]
-	   [else #f]))))
+	    [else #f]))))
 
   (define-teach beginner equal?
     (lambda (a b)
@@ -248,25 +249,54 @@
       (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
+      (make-exn:fail:contract
-      (string->immutable-string
+	(string->immutable-string
-       (string-append "quicksort: " (format fmt-str x)))
+	  (string-append (format "~a : " quicksort) (apply format fmt-str x)))
-      (current-continuation-marks))))
+	(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)
       (check-second/cycle 'cons a b)
@@ -298,25 +328,28 @@
       (apply append! x)))
 
   (provide beginner-not
-	   beginner-+
+    beginner-+
-	   beginner-/
+    beginner-/
-	   beginner-*
+    beginner-*
-	   beginner-list?
+    beginner-list?
-           beginner-member
+    beginner-member
-	   beginner-cons
+    beginner-cons
-	   beginner-list*
+    beginner-list*
-	   beginner-append
+    beginner-append
-	   beginner-error
+    beginner-error
-	   beginner-struct?
+    beginner-struct?
-	   beginner-exit
+    beginner-exit
-	   beginner-equal?
+    beginner-equal?
-	   beginner-equal~?
+    beginner-equal~?
-	   beginner-=~
+    beginner-=~
-           intermediate-quicksort
+    intermediate-quicksort
-	   advanced-cons
+    intermediate-foldr
-	   advanced-set-cdr!
+    intermediate-foldl
-	   advanced-set-rest!
+    intermediate-build-string
-	   advanced-list*
+    advanced-cons
-	   advanced-append
+    advanced-set-cdr!
-	   advanced-append!
+    advanced-set-rest!
-	   cyclic-list?))
+    advanced-list*
+    advanced-append
+    advanced-append!
+    cyclic-list?))