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

fixed an x/y reversal bug and improved the #:layout function so it isn't called as much

Browse Source 
svn: r13116
This commit is contained in:
Robby Findler 2009-01-14 18:05:21 +00:00
parent d1f65ae6c9
commit ae1e6ca263
2 changed files with 19 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/redex/private/traces.ss
View File

@ -86,7 +86,7 @@
(λ (ed) (λ (ed)
(let ([yb (box 0)] (let ([yb (box 0)]
[snip (term-node-snip term-node)]) [snip (term-node-snip term-node)])
(if (send ed get-snip-location snip yb #f #f) (if (send ed get-snip-location snip #f yb #f)
(unbox yb) (unbox yb)
0))))) 0)))))
@ -145,7 +145,7 @@
(define (print-to-ps graph-pb filename) (define (print-to-ps graph-pb filename)
(let ([admin (send graph-pb get-admin)] (let ([admin (send graph-pb get-admin)]
[printing-admin (new printing-editor-admin%)]) [printing-admin (new printing-editor-admin% [ed graph-pb])])
(send graph-pb set-admin printing-admin) (send graph-pb set-admin printing-admin)
(dynamic-wind (dynamic-wind
@ -153,7 +153,7 @@
(λ () (λ ()
(let loop ([snip (send graph-pb find-first-snip)]) (let loop ([snip (send graph-pb find-first-snip)])
(when snip (when snip
(send snip size-cache-invalid) (send (send snip get-admin) resized snip #t)
(loop (send snip next)))) (loop (send snip next))))
(send graph-pb invalidate-bitmap-cache) (send graph-pb invalidate-bitmap-cache)
@ -179,6 +179,8 @@
(define printing-editor-admin% (define printing-editor-admin%
(class editor-admin% (class editor-admin%
(init-field ed)
(define temp-file (make-temporary-file "redex-size-snip-~a")) (define temp-file (make-temporary-file "redex-size-snip-~a"))
(define ps-dc (define ps-dc
@ -270,7 +272,7 @@
"Reducing..." "Reducing..."
lower-panel lower-panel
(lambda (x y) (lambda (x y)
(reduce-button-callback)))) (reduce-button-callback #f))))
(define status-message (instantiate message% () (define status-message (instantiate message% ()
(label "") (label "")
(parent lower-panel) (parent lower-panel)
@ -411,7 +413,6 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb)))) (set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0 (begin0
(insert-into col y graph-pb new-snips) (insert-into col y graph-pb new-snips)
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence) (send graph-pb end-edit-sequence)
(send status-message set-label (send status-message set-label
(string-append (term-count (count-snips)) "...")))))]) (string-append (term-count (count-snips)) "...")))))])
@ -455,9 +456,10 @@
(send reduce-button enable #t) (send reduce-button enable #t)
(send font-size enable #t)) (send font-size enable #t))
;; reduce-button-callback : -> void ;; reduce-button-callback : boolean -> void
;; =eventspace main thread= ;; =eventspace main thread=
(define (reduce-button-callback) (define (reduce-button-callback show-all-at-once?)
(when show-all-at-once? (send graph-pb begin-edit-sequence))
(send reduce-button enable #f) (send reduce-button enable #f)
(send reduce-button set-label "Reducing...") (send reduce-button set-label "Reducing...")
(thread (thread
@ -465,6 +467,10 @@
(do-some-reductions) (do-some-reductions)
(queue-callback (queue-callback
(lambda () ;; =eventspace main thread= (lambda () ;; =eventspace main thread=
(send graph-pb begin-edit-sequence)
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence)
(when show-all-at-once? (send graph-pb end-edit-sequence))
(scroll-to-rightmost-snip) (scroll-to-rightmost-snip)
(send reduce-button set-label "Reduce") (send reduce-button set-label "Reduce")
(cond (cond
@ -542,7 +548,6 @@
null))) null)))
(out-of-dot-state) ;; make sure the state is initialized right (out-of-dot-state) ;; make sure the state is initialized right
(insert-into init-rightmost-x 0 graph-pb frontier) (insert-into init-rightmost-x 0 graph-pb frontier)
(send graph-pb re-run-layout)
(set-font-size (initial-font-size)) (set-font-size (initial-font-size))
(cond (cond
[no-show-frame? [no-show-frame?
@ -553,7 +558,7 @@
(yield s)) (yield s))
(values graph-pb f)] (values graph-pb f)]
[else [else
(reduce-button-callback) (reduce-button-callback #t)
(send f show #t)])) (send f show #t)]))
(define red-sem-frame% (define red-sem-frame%

8
collects/redex/redex.scrbl
View File

@ -1218,9 +1218,11 @@ The @scheme[scheme-colors?] argument, if @scheme[#t] causes
to DrScheme's Scheme mode color Scheme. If it is @scheme[#f], to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
@scheme[traces] just uses black for the color scheme. @scheme[traces] just uses black for the color scheme.
The @scheme[layout] argument is called (with all of the terms) each The @scheme[layout] argument is called (with all of the terms) when
time a new term is inserted into the window. See also new terms is inserted into the window. In general, it is called when
@scheme[term-node-set-position!]. after new terms are inserted in response to the user clicking on the
reduce button, and after the initial set of terms is inserted.
See also @scheme[term-node-set-position!].
You can save the contents of the window as a postscript file You can save the contents of the window as a postscript file
from the menus. from the menus.