Yep, another sync.

svn: r13146

collects/macro-debugger/model/steps.ss

@@ -40,11 +40,13 @@
 
 ;; context-fill : Context Syntax -> Syntax
 (define (context-fill ctx stx)
-  (let loop ([ctx ctx] [stx stx])
+  (datum->syntax
-    (if (null? ctx)
+   #f
-        stx
+   (let loop ([ctx ctx] [stx stx])
-        (let ([frame0 (car ctx)])
+     (if (null? ctx)
-          (loop (cdr ctx) (frame0 stx))))))
+         stx
+         (let ([frame0 (car ctx)])
+           (loop (cdr ctx) (frame0 stx)))))))
 
 (define (state-term s)
   (context-fill (state-ctx s) (state-e s)))

collects/macro-debugger/syntax-browser/widget.ss

@@ -111,7 +111,8 @@
                                #:shift-table [shift-table #f]
                                #:definites [definites null]
                                #:hi-colors [hi-colors null]
-                               #:hi-stxss [hi-stxss null])
+                               #:hi-stxss [hi-stxss null]
+                               #:substitutions [substitutions null])
       (define (get-binders id)
         (define binder
           (module-identifier-mapping-get alpha-table id (lambda () #f)))
@@ -120,11 +121,21 @@
             (list binder)))
       (let ([display (internal-add-syntax stx)]
             [definite-table (make-hasheq)])
-        (for-each (lambda (hi-stxs hi-color)
+        (let ([range (send: display display<%> get-range)]
-                    (send: display display<%>
+              [offset (send: display display<%> get-start-position)])
-                           highlight-syntaxes hi-stxs hi-color))
+          (for ([subst substitutions])
-                  hi-stxss
+            (for ([r (send: range range<%> get-ranges (car subst))])
-                  hi-colors)
+              (with-unlock -text
+                (send -text insert (cdr subst)
+                      (+ offset (car r))
+                      (+ offset (cdr r))
+                      #f)
+                (send -text change-style
+                      (code-style -text (send: config config<%> get-syntax-font-size))
+                      (+ offset (car r))
+                      (+ offset (cdr r)))))))
+        (for ([hi-stxs hi-stxss] [hi-color hi-colors])
+          (send: display display<%> highlight-syntaxes hi-stxs hi-color))
         (for ([definite definites])
           (hash-set! definite-table definite #t)
           (when shift-table

collects/macro-debugger/view/frame.ss

@@ -183,6 +183,9 @@
                          'always
                          'over-limit))
               (send: widget widget<%> update/preserve-view))))
+      (menu-option/notify-box extras-menu
+                              "Factor out common context?"
+                              (get-field split-context? config))
       (menu-option/notify-box extras-menu
                               "Highlight redex/contractum"
                               (get-field highlight-foci? config))

collects/macro-debugger/view/interfaces.ss

@@ -16,7 +16,8 @@
                    one-by-one?
                    extra-navigation?
                    debug-catch-errors?
-                   force-letrec-transformation?)))
+                   force-letrec-transformation?
+                   split-context?)))
 
 (define-interface widget<%> ()
   (get-config

collects/macro-debugger/view/prefs.ss

@@ -26,6 +26,7 @@
 (preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
 (preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
 (preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
+(preferences:set-default 'MacroStepper:SplitContext? #f boolean?)
 
 (pref:get/set pref:width MacroStepper:Frame:Width)
 (pref:get/set pref:height MacroStepper:Frame:Height)
@@ -42,6 +43,7 @@
 (pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
 (pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
 (pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
+(pref:get/set pref:split-context? MacroStepper:SplitContext?)
 
 (define macro-stepper-config-base%
   (class* syntax-prefs-base% (config<%>)
@@ -56,6 +58,7 @@
     (notify-methods extra-navigation?)
     (notify-methods debug-catch-errors?)
     (notify-methods force-letrec-transformation?)
+    (notify-methods split-context?)
     (super-new)))
 
 (define macro-stepper-config/prefs%
@@ -75,6 +78,7 @@
     (connect-to-pref extra-navigation? pref:extra-navigation?)
     (connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
     (connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
+    (connect-to-pref split-context? pref:split-context?)
     (super-new)))
 
 (define macro-stepper-config/prefs/readonly%
@@ -93,4 +97,5 @@
     (connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
     (connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
     (connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
+    (connect-to-pref/readonly split-context? pref:split-context?)
     (super-new)))

collects/macro-debugger/view/step-display.ss

@@ -139,13 +139,53 @@
     (define/private (separator/small step)
       (insert-step-separator/small
        (step-type->string (protostep-type step))))
-    
+
     ;; show-step : Step -> void
     (define/private (show-step step binders shift-table)
-      (show-state/redex (protostep-s1 step) binders shift-table)
+      (let-values ([(common-context state1 state2)
-      (separator step)
+                    (factor-common-context (protostep-s1 step)
-      (show-state/contractum (step-s2 step) binders shift-table)
+                                           (step-s2 step))])
-      (show-lctx step binders shift-table))
+        (show-state/redex state1 binders shift-table)
+        (separator step)
+        (show-state/contractum state2 binders shift-table)
+        (show-common-context common-context state1 binders shift-table)
+        (show-lctx step binders shift-table)))
+
+    (define/private (factor-common-context state1 state2)
+      (if (send: config config<%> get-split-context?)
+          (factor-common-context* state1 state2)
+          (values null state1 state2)))
+
+    (define/private (factor-common-context* state1 state2)
+      (match-define
+       (struct state (e1 foci1 ctx1 lctx1 binders1 uses1 frontier1 seq1)) state1)
+      (match-define
+       (struct state (e2 foci2 ctx2 lctx2 binders2 uses2 frontier2 seq2)) state2)
+      (define (common xs ys acc)
+        (if (and (pair? xs) (pair? ys) (eq? (car xs) (car ys)))
+            (common (cdr xs) (cdr ys) (cons (car xs) acc))
+            (values (reverse xs) (reverse ys) acc)))
+      (define-values (ctx1z ctx2z common-ctx)
+        (common (reverse ctx1) (reverse ctx2) null))
+      (define state1z
+        (make-state e1 foci1 ctx1z lctx1 binders1 uses1 frontier1 seq1))
+      (define state2z
+        (make-state e2 foci2 ctx2z lctx2 binders2 uses2 frontier2 seq2))
+      (values common-ctx state1z state2z))
+
+    (define/private (show-common-context ctx state1 binders shift-table)
+      (match-define
+       (struct state (_ _ _ _ _ uses1 frontier1 _)) state1)
+      (when (pair? ctx)
+        (let* ([hole-stx #'~~HOLE~~]
+               [the-syntax (context-fill ctx hole-stx)])
+          (send*: sbview sb:syntax-browser<%>
+            (add-text "\nin context:\n")
+            (add-syntax the-syntax
+                        #:binder-table binders
+                        #:shift-table shift-table
+                        #:definites uses1
+                        #:substitutions (list (cons hole-stx "[ HOLE ]")))))))
 
     (define/private (show-state/redex state binders shift-table)
       (insert-syntax/redex (state-term state)

collects/macro-debugger/view/stepper.ss

@@ -153,6 +153,8 @@
     (send*: config config<%>
       (listen-show-hiding-panel?
        (lambda (show?) (show-macro-hiding-panel show?)))
+      (listen-split-context?
+       (lambda (_) (update/preserve-view)))
       (listen-highlight-foci?
        (lambda (_) (update/preserve-view)))
       (listen-highlight-frontier?

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "14jan2009")
+#lang scheme/base (provide stamp) (define stamp "15jan2009")

collects/scheme/help.ss

@@ -36,8 +36,9 @@
       [_
        (raise-syntax-error
         #f
-        (string-append "expects a single identifer, any number of literal"
+        (string-append "expects any number of literal strings, a single"
-                       " strings, or #:search clauses;"
+                       " identifier, an identifier followed by a #:from clause,"
+                       " or a #:search clause;"
                        " try `(help help)' for more information")
         stx)])))
 

collects/teachpack/2htdp/scribblings/universe.scrbl

@@ -126,7 +126,7 @@ Your program may deal with such events via the @emph{designation} of
  installation of three event handlers: @scheme[on-tick], @scheme[on-key],
  and @scheme[on-mouse]. In addition, a @tech{world} program may specify a
  @scheme[draw] function, which is called every time your program should
- visualize the current world, and a @scheme[_stop?] predicate, which is used
+ visualize the current world, and a @scheme[done] predicate, which is used
  to determine when the @tech{world} program should shut down. 
 
 Each handler function consumes the current state of the @tech{world} and
@@ -835,7 +835,7 @@ The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handle
 
 The diagram below summarizes the extensions of this section in graphical form. 
 
-@image["world.png"]
+@image["universe.png"]
 
 A registered world program may send a message to the universe server
  at any time by returning a @tech{Package} from an event handler. The
@@ -964,7 +964,7 @@ A @tech{server} keeps track of information about the @tech{universe} that
  a server tracks and how the information is represented depends on the
  situation and the programmer, just as with @tech{world} programs.
 
-@deftech{UniverseState} @scheme[any/c] represents the server's state For running
+@deftech{UniverseState} @scheme[any/c] represents the server's state. For running
 @tech{universe}s, the teachpack demands that you come up with a data
 definition for (your state of the) @tech{server}.  Any piece of data can
 represent the state. We just assume that you introduce a data definition
@@ -1368,7 +1368,7 @@ The second step of the design recipe calls for functional examples:
 
 ;; an example for receiving a message from the active world:
 (check-expect
- (switch (list world1 world2) '* world1 'it-is-your-turn)
+ (switch (list world1 world2) '* world1 'done)
  (make-bundle (list world2 world1)
               '*
               (list (make-mail world2 'it-is-your-turn))))
@@ -1421,16 +1421,20 @@ Similarly, the protocol says that when @emph{switch} is invoked because a
  that there is at least this one world on this list. It is therefore
  acceptable to create a mail for this world. 
 
+Start the server now. 
+
+ @schemeblock[(universe '* (on-new add-world) (on-msg switch))]
+          
 Exercise: The function definition simply assumes that @emph{wrld} is
  @scheme[world=?] to @scheme[(first univ)] and that the received message
- @emph{m} is @scheme['it-is-your-turn]. Modify the function definition so that it
+ @emph{m} is @scheme['done]. Modify the function definition so that it
  checks these assumptions and raises an error signal if either of them is
  wrong. Start with functional examples. If stuck, re-read the section on
  checked functions from HtDP. (Note: in a @tech{universe} it is quite
  possible that a program registers with a @tech{server} but fails to stick
  to the agreed-upon protocol. How to deal with such situations properly
- depends on the context. For now, stop the @tech{universe} at this point,
+ depends on the context. For now, stop the @tech{universe} at this point by
- but consider alternative solutions, too.) 
+ returning an empty list of worlds. Consider alternative solutions, too.) 
 
 Exercise: An alternative state representation would equate 
  @tech{UniverseState} with @emph{world} structures, keeping track of the
@@ -1533,7 +1537,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function
 
 (define (receive w m)
   (cond
-    [(symbol=? 'resting w) HEIGHT]
+    [(symbol? w) HEIGHT] ;; meaning: @scheme[(symbol=? w 'resting)]
     [else w]))
 ))
 
@@ -1573,7 +1577,7 @@ the scene every time @scheme['it-is-your-turn] is received. Design this function
     [(number? x) (if (<= x 0) (make-package 'resting 'done) (sub1 x))]))
 ))
 
- Exercise: what could happen if we had designed @emph{receive} so that it
+Exercise: what could happen if we had designed @emph{receive} so that it
  produces @scheme['resting] when the state of the world is @scheme[0]?  Use
  your answer to explain why you think it is better to leave this kind of
  state change to the tick event handler instead of the message receipt
@@ -1591,7 +1595,7 @@ Finally, here is the third function, which renders the state as a scene:
 (check-expect (render 'resting)
               (place-image  (text "resting" 11 'red) 10 10 MT))
 
-(define (render name)
+(define (render w)
   (place-image 
     (text name 11 'black) 5 85 
     (cond

collects/teachpack/nuworld.ss

@@ -10,7 +10,8 @@
     "  (on-draw render WIDTH HEIGHT)"
     "  (on-tick tock RATE)"
     "  (on-mouse click)"
-    "  (on-key react))"
+    "  (on-key react)"
+    "  (stop-when done))"
     ))
 
 (define program 
@@ -114,6 +115,6 @@
 
 (draw-pict the-image image-dc 0.0 0.0)
 
-(send image-bm save-file "world.png" 'png)
+(send image-bm save-file "nuworld.png" 'png)
 
 the-image

collects/teachpack/world.ss

@@ -12,6 +12,7 @@
     "  (on-mouse click)"
     "  (on-key react)"
     "  (on-receive receive)"
+    "  (stop-when done)"
     "  (register LOCALHOST 'jimbob))"))