more api for batch-io

svn: r18808

collects/2htdp/batch-io.ss

@@ -2,41 +2,54 @@
 
 (require htdp/error)
 
+;; todo
+;; -- read files as "white space separated tokens"
+;; -- read csv files 
+;; -- tokenization? how? map-file? on a string? 
+
+(provide 
+ read-file ;; String -> String
+ ;; read the file f (in current-directory) as a string
+ 
+ read-file-as-lines ;; String -> [Listof String]
+ ;; read the file f (in current-directory) as a list of strings
+ 
+ read-file-as-1strings ;; String -> [Listof 1String]
+ ;; read the file f (in current-directory) as a list of 1strings
+
+ write-file ;; String String -> Boolean
+ ;; write str to file f (in current-directory); 
+ ;; false, if f exists
+ ;; true, if f doesn't exist
+ )
+
 (define (read-file f)
   (check-file f 'read-file)
   (check-arg 'read-file (file-exists? f) "name of file in program's folder" "first" f)
-  (list->string
-   (with-input-from-file f 
-     (lambda ()
-       (let loop ([accu '()])
-         (define nxt (read-char))
-         (if (eof-object? nxt)
-             (reverse (if (char=? (car accu) #\newline) (cdr accu) accu))
-             (loop (cons nxt accu))))))))
-
-(define (read-file-as-lines f)
-  (check-file f 'read-file-as-lines)
-  (with-input-from-file f 
-    (lambda ()
-      (let loop ([accu '()])
-        (define nxt (read-line))
-        (if (eof-object? nxt)
-            (reverse accu)
-            (loop (cons nxt accu)))))))
+  (list->string (read-chunks f read-char drop-last-newline)))
 
 (define (read-file-as-1strings f)
   (check-file f 'read-file-as-1strings)
-  (read-chars f string))
+  (map string (read-chunks f read-char drop-last-newline)))
 
-;; 
-(define (read-chars f action)
+(define (read-file-as-lines f)
+  (check-file f 'read-file-as-lines)
+  (read-chunks f read-line reverse))
+
+;; String (-> X) ([Listof X] -> [Listof X]) -> [Listof X]
+;; read a file as a list of X where process-accu is applied to accu when eof
+(define (read-chunks f read-chunk process-accu)
   (with-input-from-file f 
     (lambda ()
       (let loop ([accu '()])
-        (define nxt (read-char))
-        (if (eof-object? nxt)
-            (reverse (if (char=? (car accu) #\newline) (cdr accu) accu))
-            (loop (cons nxt accu)))))))
+        (define nxt (read-chunk))
+        (if (eof-object? nxt) (process-accu accu) (loop (cons nxt accu)))))))
+
+;; [Listof Char] -> [Listof Char]
+(define (drop-last-newline accu)
+  (reverse (if (char=? (car accu) #\newline) (cdr accu) accu)))
+
+;; -----------------------------------------------------------------------------
 
 (define (write-file f str)
   (check-arg 'write-file (string? f) "name of file (string)" "first" f)
@@ -49,25 +62,22 @@
 
 ;; -----------------------------------------------------------------------------
 
-(provide 
- read-file-as-lines ;; String -> [Listof String]
- ;; read the fule f (in current-directory) as a list of strings
- 
- read-file ;; String -> String
- ;; read the file f (in current-directory) as a string
- 
- write-file ;; String String -> Boolean
- ;; write str to file f (in current-directory); 
- ;; false, if f exists
- ;; true, if f doesn't exist
- )
-
 ;; String[file name] Symbol -> Void
 ;; effect: ensure that f is a file in current directory or report error for t
 (define (check-file f t)
   (check-arg t (string? f) "string" "first" f)
   (check-arg t (file-exists? f) "name of file in program's folder" "first" f))
 
+;; -----------------------------------------------------------------------------
+
+#|
+(require scheme/class)
+(require scheme/gui)
+
+(define (read-image-file file-name)
+  (make-object image-snip% file-name))
+|#
+
 ;                                                                               
 ;                                                                               
 ;                                                                               
@@ -86,7 +96,9 @@
 
 #|
 
-For basic i/o, I find the following two functions extremely helpful to provide as a teachpack along with what batch-io gives. Perhaps it would be possible to include them in the standard teachpack?
+For basic i/o, I find the following two functions extremely helpful to provide as a 
+  teachpack along with what batch-io gives. Perhaps it would be possible to include 
+  them in the standard teachpack?
 
  ;; split : String String -> Listof[String]
  ;; splits a string into a list of substrings using the given delimiter (space

collects/2htdp/tests/batch-io.ss

@@ -19,16 +19,31 @@ eos
                (second test2-as-list))))
 
 (or (write-file file test1)
-    (check-true (string=? (read-file file) test1) "read-file 1"))
+    (check-true (string=? (read-file file) test1) " 1"))
 
 (or (write-file file test2)
-    (check-true (string=? (read-file file) test2) "read-file 2"))
+    (check-true (string=? (read-file file) test2) " 2"))
 
 (or (write-file file test1)
-    (check-equal? (read-file-as-lines file) (list test1) "read-file-as-lines 1"))
+    (check-equal? (read-file-as-lines file) (list test1) "-as-lines 1"))
 
 (or (write-file file test2)
-    (check-equal? (read-file-as-lines file) test2-as-list "read-file-as-lines 2"))
+    (check-equal? (read-file-as-lines file) test2-as-list "-as-lines 2"))
+
+(define as-1strings1 (map string (string->list test1)))
+(or (write-file file test1)
+    (check-equal? (read-file-as-1strings file) as-1strings1 "-as-1strings 1"))
+
+(define as-1strings2 
+  (map string
+       (apply append 
+              (map string->list 
+                   (cdr
+                    (foldr (lambda (f r) (cons "\n" (cons f r))) '() 
+                           test2-as-list))))))
+
+(or (write-file file test2)
+    (check-equal? (read-file-as-1strings file) as-1strings2 "-as-lines 2"))
 
 
 (check-exn exn:fail:contract? (lambda () (write-file 0 1)))
@@ -41,3 +56,6 @@ eos
 (check-exn exn:fail:contract? (lambda () (read-file-as-lines 0)))
 (check-exn exn:fail:contract? (lambda () (read-file-as-lines '("test"))))
 
+(check-exn exn:fail:contract? (lambda () (read-file-as-1strings 0)))
+(check-exn exn:fail:contract? (lambda () (read-file-as-1strings '("test"))))
+

collects/2htdp/tests/on-tick-defined.ss

@@ -6,16 +6,35 @@
 
 (error-print-source-location #f)
 
-(define legal "on-tick: not a legal clause in a world description")
-(define double ", on-tick has been redefined")
+(define legal "~a: not a legal clause in a world description")
+(define double 
+  (string-append (format legal 'on-tick) ", on-tick has been redefined"))
 
 (with-handlers ((exn:fail:syntax? 
                  (lambda (x) 
-                   (unless 
-                       (string=? (exn-message x) (string-append legal double))
-                     (raise x)))))
+                   (unless (string=? (exn-message x) double) (raise x)))))
   (eval '(module a scheme 
            (require 2htdp/universe)
            (local ((define (run) (big-bang 0 (on-tick on-tick)))
                    (define (on-tick t) 0))
              10))))
+
+;; purpose: catch illegal shapes of the form (kwd . stuff)
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (e)
+                   (unless (string=? (exn-message e) (format legal 'on-tic))
+                     (raise e)))))
+  (eval '(module a scheme
+           (require 2htdp/universe)
+           (big-bang 0 (on-tic add1)))))
+
+;; purpose: catch illegal atomic clauses 
+
+(with-handlers ((exn:fail:syntax? 
+                 (lambda (e)
+                   (unless (string=? (exn-message e) (format legal 'stop-when))
+                     (raise e)))))
+  (eval '(module a scheme
+           (require 2htdp/universe)
+           (big-bang 0 (on-tick add1) stop-when))))