fixed dir, path->string

svn: r2502

collects/htdp/Test/dir.ss

@@ -9,7 +9,7 @@
 
 (append
  (map (lambda (x) (format "in Teachpacks, not in Test: ~s" x))
-      (filter (lambda (x) (boolean? (member x current-files))) teachps-files))
+      (filter (lambda (x) (not (member x current-files))) teachps-files))
  (map (lambda (x) (format "in Test, not in  Teachpacks: ~s" x))
-      (filter (lambda (x) (boolean? (member x teachps-files))) current-files)))
+      (filter (lambda (x) (not (member x teachps-files))) current-files)))
 

collects/htdp/big-draw.ss

@@ -152,6 +152,52 @@
     (let ((current-window (open-viewport "Canvas" WIDTH HEIGHT))
           (*delta* 0))
       (set! @vp current-window)
+      (set! @pm (open-pixmap "Canvas" WIDTH HEIGHT))
+      (set-draw-ops current-window)
+      (set! %on-key-event
+	(lambda (f)
+	  (check-proc 'on-key-event f 2 'first 'two)
+	  ((set-on-key-event current-window) 
+	   (lambda (x y) (f (key-value x) y)))
+	  #t))
+      
+      (set! %on-tick-event
+	(lambda (f)
+	  (let* ([w (ceiling (* 1000 *delta*))]
+		 [w (if (exact? w) w (inexact->exact w))])
+	    (check-proc 'on-key-event f 1 'first 'one)
+	    ((set-on-tick-event current-window) w
+	     (lambda (x) (f x)))
+	    #t)))
+      
+      (set! %big-bang 
+	(lambda (delta w)
+	  (check-arg 'big-bang
+	    (and (number? delta) (>= delta 0))
+	    "number [of seconds] between 0 and 1000000"
+	    "first"
+	    delta)
+	  (set! *delta* delta)
+	  ((init-world current-window) w) #t))
+      
+      (set! %end-of-time (lambda () ((stop-tick current-window))))
+      #t))
+
+  (define @pm #f)
+
+  (define (begin-draw-sequence width height)
+    (check-arg 'start (and (integer? width) (> width 0)) "positive integer" "first" width)
+    (check-arg 'start (and (integer? height) (> height 0)) "positive integer" "second" height)
+    ([draw-rectangle @pm] (make-posn 0 0) width height "white")
+    (set-draw-ops @pm)
+    #t)
+
+  (define (end-draw-sequence)
+    (copy-viewport @pm @vp)
+    (set-draw-ops @vp)
+    #t)
+
+  (define (set-draw-ops current-window)
     (set! %clear-all (clear-viewport current-window))
       
     (set! %draw-solid-line
@@ -184,51 +230,23 @@
     (set! %draw-string (make-%string 'draw-string (draw-string current-window)))
     (set! %clear-string (make-%string 'clear-string (clear-string current-window)))
       
-      
     (set! %wait-for-mouse-click
       (lambda ()
 	(mouse-click-posn
-               (get-mouse-click @vp))))
+	  (get-mouse-click current-window))))
       
     (set! %get-key-event
       (lambda ()
 	(cond
-                [(ready-key-press @vp) => key-value]
+	  [(ready-key-press current-window) => key-value]
 	  [else false])))
 
-      (set! %on-key-event
-            (lambda (f)
-              (check-proc 'on-key-event f 2 'first 'two)
-              ((set-on-key-event @vp) 
-               (lambda (x y) (f (key-value x) y)))
-              #t))
-      
-      (set! %on-tick-event
-            (lambda (f)
-              (let* ([w (ceiling (* 1000 *delta*))]
-                     [w (if (exact? w) w (inexact->exact w))])
-                (check-proc 'on-key-event f 1 'first 'one)
-                ((set-on-tick-event @vp) w f)
-                #t)))
-      
-      (set! %big-bang 
-            (lambda (delta w)
-              (check-arg 'big-bang
-                         (and (number? delta) (>= delta 0))
-                         "number [of seconds] between 0 and 1000000"
-                         "first"
-                         delta)
-              (set! *delta* delta)
-              ((init-world @vp) w) #t))
-      
-      (set! %end-of-time (lambda () ((stop-tick @vp))))
-      
     (set! %get-mouse-event
       (lambda ()
 	(cond
-                [(ready-mouse-click @vp) => mouse-click-posn]
+	  [(ready-mouse-click current-window) => mouse-click-posn]
 	  [else false])))
-      #t))
+    #t)
   
   (define (stop)
     (close-graphics)
@@ -256,8 +274,6 @@
     (set! %get-mouse-event the-error)
     #t)
   
-  
-  
   ;; start/cartesian-plane : Number Number -> true
   ;; start up a canvas of size width x height  and draw a centered cartesian coordinate
   (define (start/cartesian-plane width height)
@@ -272,7 +288,7 @@
 	(draw-solid-line (make-posn 0 mid-y) (make-posn width mid-y)))))
   
   (define @vp #f)
-  #cs(define (get-@VP) @vp)
+  (define (get-@VP) @vp)
   
   (provide-signature-elements draw^)
   

collects/htdp/dir.ss

@@ -1,6 +1,7 @@
 #cs(module dir mzscheme
   (require (lib "error.ss" "htdp")
            (lib "list.ss")
+           (lib "etc.ss")
            (lib "prim.ss" "lang"))
   
   (provide
@@ -33,19 +34,20 @@
   
   (define (create-dir/proc a-path)
     (check-arg 'create-dir (string? a-path) "string" "first" a-path)    
-    (if (directory-exists? a-path)
+    (let ([a-path! (string->path a-path)])
-        (car (explore (list a-path)))
+      (if (directory-exists? a-path!)
-        (error 'create-dir "not a directory: ~e" a-path)))
+          (car (explore (list a-path!)))
+          (error 'create-dir "not a directory: ~e" a-path))))
   
   ;; explore : (listof String[directory-names]) -> (listof Directory)
   (define (explore dirs)
     (map (lambda (d) 
            (let-values ([(fs ds) (pushd d directory-files&directories)]) 
              (make-dir
-              (string->symbol (my-split-path d))
+              (string->symbol (path->string (my-split-path d)))
               (explore (map (lambda (x) (build-path d x)) ds))
               (map make-file
-                   (map string->symbol fs)
+                   (map (compose string->symbol path->string) fs)
                    (map (lambda (x) (if (file-exists? x) (file-size x) 0))
 			(map (lambda (x) (build-path d x)) fs))
                    (map (lambda (x) (if (link-exists? x) 'link null)) fs)))))

collects/htdp/draw-sig.ss

@@ -19,7 +19,11 @@
         wait-for-mouse-click ; -> posn
         get-key-event   ; -> (union #f char symbol)
 	get-mouse-event ; -> (union #f posn)
-        get-@VP        
+	;; 
+        get-@VP         ; -> Viewport
+	begin-draw-sequence ; Nat Nat -> #t
+	end-draw-sequence   ; -> #t
+	;; 
         big-bang        ; World -> true
         on-key-event    ; (union char symbol) World -> World 
         on-tick-event   ; World -> World 

collects/htdp/world.ss

@@ -169,7 +169,7 @@
                (label "DrScheme")
 	       (stretchable-width #f)
 	       (stretchable-height #f)
-	       (style '(no-resize-border))))
+	       (style '(no-resize-border metal))))
     (let ([c (new (class editor-canvas%
 		    (super-new)
 		    (define/override (on-char e)