suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Yep, another sync.

Browse Source 
svn: r13146
This commit is contained in:
Stevie Strickland 2009-01-15 09:15:20 +00:00
commit f72060a72b
13 changed files with 103 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/macro-debugger/model/steps.ss
View File

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

23
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -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)
(send: display display<%>
highlight-syntaxes hi-stxs hi-color))
hi-stxss
hi-colors)
(let ([range (send: display display<%> get-range)]
[offset (send: display display<%> get-start-position)])
(for ([subst substitutions])
(for ([r (send: range range<%> get-ranges (car subst))])
(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

3
collects/macro-debugger/view/frame.ss
View File

@ -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))

3
collects/macro-debugger/view/interfaces.ss
View File

@ -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

5
collects/macro-debugger/view/prefs.ss
View File

@ -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)))

50
collects/macro-debugger/view/step-display.ss
View File

@ -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)
(separator step)
(show-state/contractum (step-s2 step) binders shift-table)
(show-lctx step binders shift-table))
(let-values ([(common-context state1 state2)
(factor-common-context (protostep-s1 step)
(step-s2 step))])
(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)

2
collects/macro-debugger/view/stepper.ss
View File

@ -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?

2
collects/repos-time-stamp/stamp.ss
View File

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

5
collects/scheme/help.ss
View File

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

24
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -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,
but consider alternative solutions, too.)
depends on the context. For now, stop the @tech{universe} at this point by
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

BIN
collects/teachpack/nuworld.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 15 KiB

After

Width:  |  Height:  |  Size: 17 KiB

5
collects/teachpack/nuworld.ss
View File

@ -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

1
collects/teachpack/world.ss
View File

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