some clean up

svn: r15866

collects/2htdp/private/checked-cell.ss

@@ -1,6 +1,6 @@
 #lang scheme/gui
 
-(require htdp/error)
+(require htdp/error mzlib/pconvert)
 
 (provide checked-cell%)
 
@@ -36,7 +36,19 @@
     (define/private (show-state)
       (define xbox (box #f)) ;; x coordinate (throw away)
       (define ybox (box 0))  ;; y coordinate for next snip
-      (define s (pretty-format value 80))
+      (define s
+        (pretty-format
+         (parameterize ([constructor-style-printing #t]
+                        [booleans-as-true/false #t]
+                        [abbreviate-cons-as-list 
+                         #t
+                         ;; is this beginner or beginner+quote
+                         #;
+                         (let ([o (open-output-string)])
+                           (print '(1) o)
+                           (regexp-match #rx"list" (get-output-string o)))])
+           (print-convert value)) 
+         40))
       ;; turn s into lines and display them in pb
       (send pb erase)
       (if (is-a? value snip%)

collects/2htdp/private/syn-aux.ss

@@ -1,19 +1,60 @@
 #lang scheme
 
-(provide define-keywords function-with-arity expr-with-check except err)
+(provide define-keywords function-with-arity expr-with-check except err 
+         ->args
+         ->kwds-in
+         clauses-use-kwd)
 
 (require 
  (for-template "syn-aux-aux.ss" 
                scheme
                (rename-in lang/prim (first-order->higher-order f2h))))
 
+#|
+  transform the clauses into the initial arguments specification 
+  for a new expression that instantiates the appropriate class
+  
+  ensure that all clauses mention only keywords specified in AllSpec or PartSpec
+  move the contracts from AppSpecl and PartSpec to the clauses 
+  
+  run ->rec? over all used keywords to discover the presence of special clauses
+  
+  if anything fails, use the legal keyword to specialize the error message
+|#
+(define (->args stx clauses AllSpec PartSpec ->rec? legal)
+  (define msg (format "not a legal clause in a ~a description" legal))
+  (define Spec (append AllSpec PartSpec))
+  (define kwds (map (compose (curry datum->syntax stx) car) Spec))
+  (define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg (->kwds-in kwds)))
+  (map (lambda (x) 
+         (define kw (car x))
+         (define-values (key coercion)
+           (let loop ([kwds kwds][Spec Spec])
+             (if (free-identifier=? (car kwds) kw)
+                 (values (car kwds) (cadar Spec))
+                 (loop (cdr kwds) (cdr Spec)))))
+         (list key (coercion (cdr x))))
+       spec))
+
+(define (clauses-use-kwd stx:list ->rec? legal-clause kwd-in?)
+  (map (lambda (stx)
+         (syntax-case stx ()
+           [(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw) (cons #'kw stx))]
+           [_ (raise-syntax-error #f legal-clause stx)]))
+       stx:list))
+
+;; [Listof SyntaxIdentifier] -> (Syntax -> Boolean)
+(define (->kwds-in kwds)
+  (lambda (k)
+    (and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
+
 (define-syntax-rule (define-keywords the-list (kw coerce) ...)
   (begin
     (provide kw ...)
     (define-syntax (kw x)
       (raise-syntax-error 'kw "used out of context" x))
     ...
-    (define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...))))
+    (define-for-syntax the-list (list (list #'kw (coerce ''kw)) ...))))
 
 (define-syntax (expr-with-check stx)
   (syntax-case stx ()
@@ -21,7 +62,7 @@
      #`(lambda (tag)
          (lambda (p)
            (syntax-case p ()
-             [(x) #`(check> #,tag x)]
+             [(_ x) #`(check> #,tag x)]
              [_ (err tag p msg)])))]))
 
 (define-syntax function-with-arity 
@@ -30,20 +71,20 @@
      (lambda (tag)
        (lambda (p)
          (syntax-case p ()
-           [(x) #`(proc> #,tag (f2h x) arity)]
+           [(_ x) #`(proc> #,tag (f2h x) arity)]
            [_ (err tag p)])))]
     [(_ arity except extra)
      (lambda (tag)
        (lambda (p)
          (syntax-case p ()
-           [(x) #`(proc> #,tag (f2h x) arity)]
+           [(_ x) #`(proc> #,tag (f2h x) arity)]
            extra
            [_ (err tag p)])))]))
 
-(define (err spec p . extra-spec)
+(define (err spec p . xtras)
-  (printf "~s\n" p)
+  (printf ">> ~s\n" p)
   (raise-syntax-error (cadr spec)
-                      (if (null? extra-spec)
+                      (if (null? xtras)
                           "illegal specification"
-                          (string-append "illegal specification: " (car extra-spec)))
+                          (string-append "illegal specification: " (car xtras)))
                       p))

collects/2htdp/uchat/chatter.ss

@@ -1,7 +1,7 @@
 ;; The first three lines of this file were inserted by DrScheme. They record metadata
 ;; about the language level of this file in a form that our tools can easily process.
-#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname chatter) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname chatter) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
-;(require 2htdp/universe)
+(require 2htdp/universe)
 (require "auxiliaries.ss")
 
 #|

collects/2htdp/universe.ss

@@ -2,9 +2,14 @@
 
 #| TODO: 
    -- make window resizable :: why
+   -- what if clauses are repeated in world and/or universe descriptions? 
+   -- what if the initial world or universe state is omitted? the error message is bad then. 
 |#
 
-(require (for-syntax "private/syn-aux.ss")
+(require (for-syntax "private/syn-aux.ss"
+                     scheme/function
+                     #;
+                     (rename-in lang/prim (first-order->higher-order f2h)))
          "private/syn-aux-aux.ss" 
          "private/syn-aux.ss"
          "private/check-aux.ss"
@@ -13,17 +18,14 @@
          "private/universe.ss"
          "private/launch-many-worlds.ss"
          htdp/error
-         (rename-in lang/prim (first-order->higher-order f2h))
+         (rename-in lang/prim (first-order->higher-order f2h)))
-         (for-syntax (rename-in lang/prim (first-order->higher-order f2h)))
-         (only-in mzlib/etc evcase))
 
 (provide (all-from-out "private/image.ss"))
 
 (provide
  launch-many-worlds
  ;; (launch-many-worlds e1 ... e2)
- ;; run expressions e1 through e2 in parallel,
+ ;; run expressions e1 through e2 in parallel, produce all values in same order
- ;; produce all values
  )
 
 (provide
@@ -31,28 +33,17 @@
  scene? ;; Any -> Boolean 
  )
 
-;; Spec = (on-tick Expr) 
-;;      | (on-tick Expr Expr) 
-;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
-;;      = (check-with Expr)
-;; -- check-with must specify a predicate 
-;;      | (state Expr)
-;; -- state specifies whether to display the world's or universe's current state
-
 (define-keywords AllSpec
+  ;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
   [on-tick (function-with-arity
             1 
             except
-            [(x rate) 
+            [(_ x rate) 
              #'(list (proc> 'on-tick (f2h x) 1) 
                      (num> 'on-tick rate positive? "pos. number" "rate"))])]
-  [state (expr-with-check bool> "expected a boolean (show state or not)")
+  ;; -- state specifies whether to display the current state 
-         #;
+  [state (expr-with-check bool> "expected a boolean (show state or not)")]
-         (lambda (tag)
+  ;; -- check-with must specify a predicate 
-           (lambda (p)
-             (syntax-case p ()
-               [(b) #`(bool> #,tag b)]
-               [_ (err tag p "expected a boolean (show state or not)")])))]
   [check-with (function-with-arity 1)])
 
 ;                                     
@@ -75,161 +66,28 @@
          make-package ;; World Sexp -> Package
          package?     ;; Any -> Boolean 
          run-movie    ;; [Listof Image] -> true 
-         
+         mouse-event?  ;; Any -> Boolean : MOUSE-EVTS
-         ;; A MouseEventType is one of:
+         mouse=?       ;; MOUSE-EVTS MOUSE-EVTS -> Boolean 
-         ;; - 'button-down
+         key-event?    ;; Any -> Boolean : KEY-EVTS
-         ;; - 'button-up
+         key=?         ;; KEY-EVTS KEY-EVTS -> Boolean
-         ;; - 'drag
-         ;; - 'move
-         ;; - 'enter
-         ;; - 'leave
-         
-         mouse-event?  ;; Any -> Boolean 
-         mouse=?       ;; MouseEventType MouseEventType -> Boolean 
-         
-         ;; KeyEvent is one of: 
-         ;; -- Char 
-         ;; -- Symbol 
-         
-         key-event?    ;; Any -> Boolean
-         key=?         ;; KeyEvent KeyEvent -> Boolean
-         
          ;; IP : a string that points to a machine on the net 
          LOCALHOST     ;; IP
          )
 
+#;
 (provide-higher-order-primitive
  run-simulation (create-scene) ; (Number Number Number (Nat -> Scene) -> true)
  )
 
-;; Expr = (big-bang Expr WorldSpec ...)
+(define MOUSE-EVTS 
-;; WorldSpec = AllSpec 
+  '("button-down" 
-;;      | (on-draw Expr)
+    "button-up"
-;;      | (on-draw Expr Expr Expr)
+    "drag"
-;; -- on-draw must specify a rendering function; it may specify canvas dimension
+    "move"
-;;      | (on-key Expr)
+    "enter"
-;; -- on-key must specify a key event handler 
+    "leave"))
-;;      | (on-mouse Expr) 
-;; -- on-mouse must specify a mouse event handler 
-;;      | (stop-when Expr)
-;;      | (stop-when Expr Expr)
-;; -- stop-when must specify a predicate; it may specify a rendering function
-;;      | (register Expr)
-;; -- register must specify the internet address of a host (including LOCALHOST)
-;;      | (name Expr)
-;; -- the name 
-;;      | (record? Expr)
-;; -- should the session be recorded and turned into PNGs and an animated GIF
-;;      | (on-receive Expr) 
-;; -- on-receive must specify a receive handler 
 
-(define-keywords WldSpec 
+(define KEY-EVTS 
-  [on-draw (function-with-arity 
-            1 
-            except
-            [(f width height) 
-             #'(list (proc> 'on-draw (f2h f) 1) 
-                     (nat> 'on-draw width "width")
-                     (nat> 'on-draw height "height"))])]
-  [on-mouse (function-with-arity 4)]
-  [on-key (function-with-arity 2)]
-  [on-receive (function-with-arity 2)]
-  [stop-when (function-with-arity 
-              1
-              except
-              [(stop? last-picture)
-               #'(list (proc> 'stop-when (f2h stop?) 1)
-                       (proc> 'stop-when (f2h last-picture) 1))])]
-  [record? (expr-with-check bool> "expected a boolean (to record? or not)")]
-  [name (expr-with-check string> "expected a name (string) for the world")]
-  [register (expr-with-check ip> "expected a host (ip address)")])
-
-(define-syntax (big-bang stx)
-  (syntax-case stx ()
-    [(big-bang) 
-     (raise-syntax-error #f "big-bang needs at least an initial world;" stx)]
-    [(big-bang w (k s ...) ...)
-     (let* (;; [Listof (list Keyword Contract)]
-            [Spec (append AllSpec WldSpec)]
-            [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
-            [rec? #'#f]
-            ;; [Listof (cons Keyword Value)]
-            [wrld (map (lambda (stx)
-                         (syntax-case stx ()
-                           [(kw . E)
-                            (and (identifier? #'kw) 
-                                 (for/or ([n kwds]) (free-identifier=? #'kw n)))
-                            (begin
-                              (when (free-identifier=? #'kw #'record?)
-                                (syntax-case #'E ()
-                                  [(V) (set! rec? #'V)]
-                                  [_ (err 'record? stx)]))
-                              (cons #'kw #'E))]
-                           [_ (raise-syntax-error
-                               'big-bang "not a legal big-bang clause" stx)]))
-                       (syntax->list (syntax ((k s ...) ...))))]
-            ;; assert: all items of wrld have shape (kw . E) 
-            ;;         and all kw are guaranted in the domain of Spec
-            ;; now bring together the coercion-contracts and the values, 
-            ;; PLUS use the 'local' version of the keyword because it is 
-            ;; also the name of the class
-            [args (map (lambda (x) 
-                         (define kw (car x))
-                         (define-values (key coercion)
-                           (let loop ([kwds kwds][Spec Spec])
-                             (if (free-identifier=? (car kwds) kw)
-                                 (values (car kwds) (cadar Spec))
-                                 (loop (cdr kwds) (cdr Spec)))))
-                         (list key (coercion (cdr x))))
-                       wrld)])
-       #`(parameterize ([current-eventspace (make-eventspace)])
-           (let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)])
-             (send o last))))]))
-
-
-;                                                                 
-;                                                                 
-;                                                                 
-;   ;   ;                  ;        ;          ;;;                
-;   ;   ;                  ;        ;         ;   ;               
-;   ;   ;                  ;        ;         ;   ;               
-;   ;   ;   ;;;   ; ;;     ;     ;;;;         ;   ;  ;   ;  ;   ; 
-;   ;   ;  ;   ;  ;;  ;    ;    ;   ;         ;;;;;  ;   ;   ; ;  
-;   ; ; ;  ;   ;  ;   ;    ;    ;   ;         ;   ;  ;   ;    ;   
-;   ;; ;;  ;   ;  ;        ;    ;   ;         ;   ;  ;   ;    ;   
-;   ;   ;  ;   ;  ;        ;    ;   ;         ;   ;  ;  ;;   ; ;  
-;   ;   ;   ;;;   ;        ;;    ;;;;         ;   ;   ;; ;  ;   ; 
-;                                                                 
-;                                                                 
-;                                                                 
-
-(define (run-simulation f)
-  (check-proc 'run-simulation f 1 "first" "one argument")
-  (big-bang 1 (on-tick add1) (on-draw f)))
-
-(define (run-movie r m*)
-  (check-arg 'run-movie (positive? r) "positive number" "first" r)
-  (check-arg 'run-movie (list? m*) "list (of images)" "second" m*)
-  (for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*)
-  (let* ([fst (car m*)]
-         [wdt (image-width fst)]
-         [hgt (image-height fst)])
-    (big-bang 
-     m* 
-     (on-tick rest r) 
-     (on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
-     (stop-when empty?))))
-
-(define ME (map symbol->string '(button-down button-up drag move enter leave)))
-
-(define (mouse-event? a) (and (string? a) (pair? (member a ME))))
-
-(define (mouse=? k m)
-  (check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
-  (check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
-  (string=? k m))
-
-(define KEYS 
   '("left"
     "right"
     "up"
@@ -264,18 +122,85 @@
     "wheel-up"
     "wheel-down"))
 
+(define-keywords WldSpec 
+  ;; -- on-draw must specify a rendering function; it may specify dimensions
+  [on-draw (function-with-arity 
+            1 
+            except
+            [(_ f width height) 
+             #'(list (proc> 'on-draw (f2h f) 1) 
+                     (nat> 'on-draw width "width")
+                     (nat> 'on-draw height "height"))])]
+  ;; -- on-mouse must specify a mouse event handler 
+  [on-mouse (function-with-arity 4)]
+  ;; -- on-key must specify a key event handler 
+  [on-key (function-with-arity 2)]
+  ;; -- on-receive must specify a receive handler 
+  [on-receive (function-with-arity 2)]
+  ;; -- stop-when must specify a predicate; it may specify a rendering function
+  [stop-when (function-with-arity 
+              1
+              except
+              [(_ stop? last-picture)
+               #'(list (proc> 'stop-when (f2h stop?) 1)
+                       (proc> 'stop-when (f2h last-picture) 1))])]
+  ;; -- should the session be recorded and turned into PNGs and an animated GIF
+  [record? (expr-with-check bool> "expected a boolean (to record? or not)")]
+  [name (expr-with-check string> "expected a name (string) for the world")]
+  ;; -- register must specify the internet address of a host (including LOCALHOST)
+  [register (expr-with-check ip> "expected a host (ip address)")])
+
+(define-syntax (big-bang stx)
+  (define world0 "big-bang needs at least an initial world")
+  (syntax-case stx ()
+    [(big-bang) (raise-syntax-error #f world0 stx)]
+    [(big-bang w clause ...)
+     (let* ([rec? #'#f]
+            [->rec? 
+             (lambda (kw)
+               (when (free-identifier=? kw #'record?)
+                 (syntax-case #'E ()
+                   [(V) (set! rec? #'V)]
+                   [_ (err 'record? stx)])))]
+            [args (->args stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
+       #`(parameterize ([current-eventspace (make-eventspace)])
+           (let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)])
+             (send o last))))]))
+
+(define (run-simulation f)
+  (check-proc 'run-simulation f 1 "first" "one argument")
+  (big-bang 1 (on-tick add1) (on-draw f)))
+
+(define (run-movie r m*)
+  (check-arg 'run-movie (positive? r) "positive number" "first" r)
+  (check-arg 'run-movie (list? m*) "list (of images)" "second" m*)
+  (for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*)
+  (let* ([fst (car m*)]
+         [wdt (image-width fst)]
+         [hgt (image-height fst)])
+    (big-bang 
+     m* 
+     (on-tick rest r) 
+     (on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
+     (stop-when empty?))))
+
+(define (mouse-event? a) (and (string? a) (pair? (member a MOUSE-EVTS))))
+
+(define (mouse=? k m)
+  (check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
+  (check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
+  (string=? k m))
+
 (define (key-event? k) 
-  (and (string? k) (or (= (string-length k) 1) (member k KEYS))))
+  (and (string? k) (or (= (string-length k) 1) (member k KEY-EVTS))))
 
 (define (key=? k m)
-  (check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
+  (check-arg 'key=? (key-event? k) 'KEY-EVTS "first" k)
-  (check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
+  (check-arg 'key=? (key-event? m) 'KEY-EVTS "second" m)
   (string=? k m))
 
 (define LOCALHOST "127.0.0.1")
 
-;; -----------------------------------------------------------------------------
-
 ;                                                          
 ;                                                          
 ;                                                          
@@ -309,60 +234,24 @@
  universe    ;; <syntax> : see below 
  )
 
-;; Expr = (universe Expr UniSpec)
-;; UniSpec = AllSepc
-;;      | (on-new Expr)
-;; -- on-new must specify a 'new world" handler; what happens when a world joins
-;;      | (on-msg Expr)
-;; -- on-msg must specify a 'message' handler
-;;      | (on-disconnect Expr)
-;; -- on-disconnect may specify a handler for the event that a world is leaving
-;;      | (to-string Expr) 
-;; -- to-string specifies how to render the universe as a string for display 
-;;    in the console 
-
 (define-keywords UniSpec
+  ;; -- on-new must specify what happens when a world joins the universe
   [on-new (function-with-arity 2)]
+  ;; -- on-msg must specify what happens to a message from a world 
   [on-msg (function-with-arity 3)]
+  ;; -- on-disconnect may specify what happens when a world drops out
   [on-disconnect (function-with-arity 2)]
+  ;; -- to-string specifies how to render the universe as a string for display
   [to-string (function-with-arity 1)])
 
 (define-syntax (universe stx)
+  (define legal "not a legal clause in a universe description")
   (syntax-case stx ()
     [(universe) (raise-syntax-error #f "not a legal universe description" stx)]
     [(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
     [(universe u bind ...)
-     (let* ([Spec (append AllSpec UniSpec)]
+     (let* ([args (->args stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
-            [kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
+            [domain (map (compose syntax-e car) args)])
-            [spec (map (lambda (stx) 
-                         (syntax-case stx ()
-                           [(kw . E)
-                            (and (identifier? #'kw) 
-                                 (for/or ([n kwds]) (free-identifier=? #'kw n)))
-                            (cons #'kw (syntax E))]
-                           [(kw E)
-                            (and (identifier? #'kw) 
-                                 (for/or ([n kwds]) (free-identifier=? #'kw n)))
-                            (list (syntax-e #'kw) (syntax E))]
-                           [_ (raise-syntax-error
-                               'universe "not a legal universe clause" stx)]))
-                       (syntax->list (syntax (bind ...))))]
-            ;; assert: all bind = (kw . E) and kw is constrained via Bind 
-            [args (map (lambda (x) 
-                         (define kw (car x))
-                         (define co ;; patch from Jay to allow rename on import
-                           (findf (lambda (n) (free-identifier=? kw (car n)))
-                                  (map (lambda (k s) (cons k (cdr s))) 
-                                       kwds Spec)))
-                         (list (syntax-e (car co)) ((cadr co) (cdr x))))
-                       spec)]
-            #;
-            [args (map (lambda (x) 
-                         (define kw (car x))
-                         (define co (assq kw Spec))
-                         (list kw ((cadr co) (cdr x))))
-                       spec)]
-            [domain (map car args)])
        (cond
          [(not (memq 'on-new domain))
           (raise-syntax-error #f "missing on-new clause" stx)]

collects/2htdp/utest/shared.ss

@@ -23,7 +23,7 @@
                                   5 85 
                                   (empty-scene width HEIGHT)))
           
-          ;; -----------------------------------------------------------------------------
+          ;; ----------------------------------------------------------------
           ;; World Number -> Message 
           ;; on receiving a message from server, place the ball at lower end or stop
           #|
@@ -59,7 +59,7 @@
     (big-bang WORLD0 
               (on-draw draw)
               (on-receive receive)
-              (on-tick move)
+              (on-tick move .01)
               (name t)
               (check-with (lambda (w) (or (symbol? w) (number? w))))
               (register LOCALHOST))))