From 3a3ceb121b200e9a3df468fa1936eaaf9e9820f7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 10 Jan 2009 18:17:45 +0000 Subject: [PATCH] added traces/ps and some code to make automatic layout of the graph possible (see #:layout in the docs for traces) svn: r13058 --- collects/redex/HISTORY | 7 ++ collects/redex/gui.ss | 38 ++++-- collects/redex/private/traces.ss | 202 ++++++++++++++++++++++++------- collects/redex/redex.scrbl | 78 +++++++++++- 4 files changed, 271 insertions(+), 54 deletions(-) diff --git a/collects/redex/HISTORY b/collects/redex/HISTORY index 1a51f5bcc3..cd8b96dea2 100644 --- a/collects/redex/HISTORY +++ b/collects/redex/HISTORY @@ -1,3 +1,10 @@ + - added more coloring arguments to traces: #:scheme-colors? + #:default-arrow-highlight-color, and #:default-arrow-color + + - added the #:layout argument to traces + + - added term-node-set-position! + - Added tracing to metafunctions (see current-traced-metafunctions) - added caching-enabled? parameter (changed how set-cache-size! diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss index 7dfb5151c9..873595fc01 100644 --- a/collects/redex/gui.ss +++ b/collects/redex/gui.ss @@ -33,8 +33,21 @@ #:pred (or/c (any/c . -> . any) (any/c term-node? . -> . any)) #:pp pp-contract - #:colors (listof any/c)) + #:colors (listof (list/c string? string?)) + #:scheme-colors? boolean? + #:layout (-> any/c any/c)) any)] + [traces/ps (->* (reduction-relation? + any/c + (or/c path-string? path?)) + (#:multiple? + boolean? + #:pred (or/c (any/c . -> . any) + (any/c term-node? . -> . any)) + #:pp pp-contract + #:colors (listof any/c) + #:layout (-> any/c any/c)) + any)] [term-node? (-> any/c boolean?)] [term-node-parents (-> term-node? (listof term-node?))] @@ -45,6 +58,11 @@ (or/c string? (is-a?/c color%) false/c) void?)] [term-node-expr (-> term-node? any)] + [term-node-set-position! (-> term-node? real? real? void?)] + [term-node-x (-> term-node? real?)] + [term-node-y (-> term-node? real?)] + [term-node-width (-> term-node? real?)] + [term-node-height (-> term-node? real?)] [stepper (->* (reduction-relation? @@ -55,10 +73,16 @@ (->* (reduction-relation? (cons/c any/c (listof any/c))) (pp-contract) - void?)]) - - -(provide reduction-steps-cutoff initial-font-size initial-char-width - dark-pen-color light-pen-color dark-brush-color light-brush-color - dark-text-color light-text-color + void?)] + + [dark-pen-color (parameter/c (or/c string? (is-a?/c color%)))] + [light-pen-color (parameter/c (or/c string? (is-a?/c color%)))] + [dark-brush-color (parameter/c (or/c string? (is-a?/c color%)))] + [light-brush-color (parameter/c (or/c string? (is-a?/c color%)))] + [dark-text-color (parameter/c (or/c string? (is-a?/c color%)))] + [light-text-color (parameter/c (or/c string? (is-a?/c color%)))] + [initial-font-size (parameter/c number?)] + [initial-char-width (parameter/c number?)]) + +(provide reduction-steps-cutoff default-pretty-printer) \ No newline at end of file diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 5efb8c074e..3bf3888bbd 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -30,15 +30,87 @@ (define (term-node-expr term-node) (send (term-node-snip term-node) get-expr)) (define (term-node-labels term-node) (send (term-node-snip term-node) get-one-step-labels)) (define (term-node-set-color! term-node r?) - (let loop ([snip (term-node-snip term-node)]) - (parameterize ([current-eventspace (send snip get-my-eventspace)]) - (queue-callback - (λ () - (send (term-node-snip term-node) set-bad r?)))))) + (snip/eventspace + (λ () + (send (term-node-snip term-node) set-bad r?)))) (define (term-node-set-red! term-node r?) (term-node-set-color! term-node (and r? "pink"))) +(define (term-node-set-position! term-node x y) + (snip/eventspace/ed + term-node + (λ (ed) + (when ed + (send ed move-to (term-node-snip term-node) x y))))) + +(define (term-node-width term-node) + (snip/eventspace/ed + term-node + (λ (ed) + (let ([lb (box 0)] + [rb (box 0)] + [snip (term-node-snip term-node)]) + (if (and (send ed get-snip-location snip lb #f #f) + (send ed get-snip-location snip rb #f #t)) + (- (unbox rb) (unbox lb)) + 0))))) + +(define (term-node-height term-node) + (snip/eventspace/ed + term-node + (λ (ed) + (let ([tb (box 0)] + [bb (box 0)] + [snip (term-node-snip term-node)]) + (if (and (send ed get-snip-location snip #f tb #f) + (send ed get-snip-location snip #f bb #t)) + (- (unbox bb) (unbox tb)) + 0))))) + +(define (term-node-x term-node) + (snip/eventspace/ed + term-node + (λ (ed) + (let ([xb (box 0)] + [snip (term-node-snip term-node)]) + (if (send ed get-snip-location snip xb #f #f) + (unbox xb) + 0))))) + +(define (term-node-y term-node) + (snip/eventspace/ed + term-node + (λ (ed) + (let ([yb (box 0)] + [snip (term-node-snip term-node)]) + (if (send ed get-snip-location snip yb #f #f) + (unbox yb) + 0))))) + +(define (snip/eventspace/ed term-node f) + (snip/eventspace + term-node + (λ () + (let* ([snip (term-node-snip term-node)] + [admin (send snip get-admin)]) + (f (and admin (send admin get-editor))))))) + + +(define (snip/eventspace term-node thunk) + (let* ([snip (term-node-snip term-node)] + [eventspace (send snip get-my-eventspace)]) + (cond + [(eq? (current-eventspace) eventspace) + (thunk)] + [else + (let ([c (make-channel)]) + (parameterize ([current-eventspace eventspace]) + (queue-callback + (λ () + (channel-put c (thunk))))) + (channel-get c))]))) + (define initial-font-size (make-parameter (send (send (send (editor:get-standard-style-list) @@ -51,7 +123,39 @@ (define x-spacing 15) (define y-spacing 15) -(define (traces reductions pre-exprs #:multiple? [multiple? #f] #:pred [pred (λ (x) #t)] #:pp [pp default-pretty-printer] #:colors [colors '()]) +(define (traces/ps reductions pre-exprs filename + #:multiple? [multiple? #f] + #:pred [pred (λ (x) #t)] + #:pp [pp default-pretty-printer] + #:default-arrow-colors [default-arrow-colors '()] + #:scheme-colors? [scheme-colors? #t] + #:colors [colors '()] + #:layout [layout void]) + (let ([graph-pb + (traces reductions pre-exprs + #:no-show-frame? #t + #:multiple? multiple? + #:pred pred + #:pp pp + #:default-arrow-colors default-arrow-colors + #:scheme-colors? scheme-colors? + #:colors colors + #:layout layout)] + [ps-setup (make-object ps-setup%)]) + (send ps-setup copy-from (current-ps-setup)) + (send ps-setup set-file filename) + (send ps-setup set-mode 'file) + (parameterize ([current-ps-setup ps-setup]) + (send graph-pb print #t #f 'postscript #f #f)))) + +(define (traces reductions pre-exprs + #:multiple? [multiple? #f] + #:pred [pred (λ (x) #t)] + #:pp [pp default-pretty-printer] + #:colors [colors '()] + #:scheme-colors? [scheme-colors? #t] + #:layout [layout void] + #:no-show-frame? [no-show-frame? #f]) (define exprs (if multiple? pre-exprs (list pre-exprs))) (define main-eventspace (current-eventspace)) (define saved-parameterization (current-parameterization)) @@ -146,14 +250,18 @@ (semaphore-wait s) ans))) + (define default-colors (list (dark-pen-color) (light-pen-color) + (dark-text-color) (light-text-color) + (dark-brush-color) (light-brush-color))) + ;; only changed on the reduction thread ;; frontier : (listof (is-a?/c graph-editor-snip%)) (define frontier (filter (λ (x) x) - (map (lambda (expr) (build-snip snip-cache #f expr pred pp - (dark-pen-color) (light-pen-color) - (dark-text-color) (light-text-color) #f)) + (map (lambda (expr) (apply build-snip + snip-cache #f expr pred pp #f scheme-colors? + default-colors)) exprs))) ;; set-font-size : number -> void @@ -172,38 +280,29 @@ (send snip shrink-down)) (loop (send snip next)))))) - ;; color-spec-list->color-scheme : (list (union string? #f)^4) -> (list string?^4) - ;; converts a list of user-specified colors (including false) into a list of color strings, filling in - ;; falses with the default colors - (define (color-spec-list->color-scheme l) - (map (λ (c d) (or c d)) - l - (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color)))) - + ;; fill-out : (listof X) (listof X) -> (listof X) + ;; produces a list whose length matches defaults but + (define (fill-out l defaults) + (let loop ([l l] + [default defaults]) + (cond + [(null? l) defaults] + [else + (cons (car l) (loop (cdr l) (cdr defaults)))]))) (define name->color-ht (let ((ht (make-hash))) (for-each (λ (c) - (hash-set! ht (car c) - (color-spec-list->color-scheme - (match (cdr c) - [`(,color) - (list color color (dark-text-color) (light-text-color))] - [`(,dark-arrow-color ,light-arrow-color) - (list dark-arrow-color light-arrow-color (dark-text-color) (light-text-color))] - [`(,dark-arrow-color ,light-arrow-color ,text-color) - (list dark-arrow-color light-arrow-color text-color text-color)] - [`(,_ ,_ ,_ ,_) - (cdr c)])))) + (hash-set! ht (car c) (fill-out (cdr c) default-colors))) colors) ht)) - ;; red->colors : string -> (values string string string string) + ;; red->colors : string -> (values string string string string string string) (define (red->colors reduction-name) (apply values (hash-ref name->color-ht reduction-name - (λ () (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color)))))) + default-colors))) ;; reduce-frontier : -> void ;; =reduction thread= @@ -225,11 +324,13 @@ (let-values ([(name sexp) (apply values red+sexp)]) (call-on-eventspace-main-thread (λ () - (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color) + (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color + dark-pen-color + light-pen-color) (red->colors name)]) - (build-snip snip-cache snip sexp pred pp + (build-snip snip-cache snip sexp pred pp name scheme-colors? light-arrow-color dark-arrow-color dark-label-color light-label-color - name)))))) + dark-pen-color light-pen-color)))))) (apply-reduction-relation/tag-with-names reductions (send snip get-expr))))] [new-y (call-on-eventspace-main-thread @@ -239,6 +340,7 @@ (set! col (+ x-spacing (find-rightmost-x graph-pb)))) (begin0 (insert-into col y graph-pb new-snips) + (layout (hash-map snip-cache (lambda (x y) (send y get-term-node)))) (send graph-pb end-edit-sequence) (send status-message set-label (string-append (term-count (count-snips)) "...")))))]) @@ -369,9 +471,12 @@ null))) (out-of-dot-state) ;; make sure the state is initialized right (insert-into init-rightmost-x 0 graph-pb frontier) + (layout (map (lambda (y) (send y get-term-node)) frontier)) (set-font-size (initial-font-size)) (reduce-button-callback) - (send f show #t)) + (if no-show-frame? + graph-pb + (send f show #t))) (define red-sem-frame% (class (frame:standard-menus-mixin (frame:basic-mixin frame%)) @@ -509,20 +614,22 @@ ;; sexp ;; sexp -> boolean ;; (any port number -> void) -;; color ;; (union #f string) +;; color^6 ;; -> (union #f (is-a?/c graph-editor-snip%)) ;; returns #f if a snip corresponding to the expr has already been created. ;; also adds in the links to the parent snip ;; =eventspace main thread= -(define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name) +(define (build-snip cache parent-snip expr pred pp name scheme-colors? + light-arrow-color dark-arrow-color dark-label-color light-label-color + dark-brush-color light-brush-color) (let-values ([(snip new?) (let/ec k (values (hash-ref cache expr (lambda () - (let ([new-snip (make-snip parent-snip expr pred pp)]) + (let ([new-snip (make-snip parent-snip expr pred pp scheme-colors?)]) (hash-set! cache expr new-snip) (k new-snip #t)))) #f))]) @@ -532,10 +639,14 @@ (add-links/text-colors parent-snip snip (send the-pen-list find-or-create-pen dark-arrow-color 0 'solid) (send the-pen-list find-or-create-pen light-arrow-color 0 'solid) - (send the-brush-list find-or-create-brush (dark-brush-color) 'solid) - (send the-brush-list find-or-create-brush (light-brush-color) 'solid) - (make-object color% dark-label-color) - (make-object color% light-label-color) + (send the-brush-list find-or-create-brush dark-brush-color 'solid) + (send the-brush-list find-or-create-brush light-brush-color 'solid) + (if (is-a? dark-label-color color%) + dark-label-color + (make-object color% dark-label-color)) + (if (is-a? light-label-color color%) + light-label-color + (make-object color% light-label-color)) 0 0 name) (update-badness pred parent-snip (send parent-snip get-expr))) @@ -563,7 +674,7 @@ ;; -> (is-a?/c graph-editor-snip%) ;; unconditionally creates a new graph-editor-snip ;; =eventspace main thread= -(define (make-snip parent-snip expr pred pp) +(define (make-snip parent-snip expr pred pp scheme-colors?) (let* ([text (new program-text%)] [es (instantiate graph-editor-snip% () (char-width (initial-char-width)) @@ -573,6 +684,7 @@ (expr expr))]) (send text set-autowrap-bitmap #f) (send text freeze-colorer) + (send text stop-colorer (not scheme-colors?)) (send es format-expr) es)) @@ -605,12 +717,18 @@ (unbox bt)))) (provide traces + traces/ps term-node? term-node-parents term-node-children term-node-labels term-node-set-red! term-node-set-color! + term-node-set-position! + term-node-x + term-node-y + term-node-width + term-node-height term-node-expr) (provide reduction-steps-cutoff initial-font-size diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 1d9f533dde..7e3101bfe5 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1117,13 +1117,21 @@ exploring reduction sequences. [expr (or/c any/c (listof any/c))] [#:multiple? multiple? boolean? #f] [#:pred pred - (or/c (sexp -> any) (sexp term-node? any)) + (or/c (-> sexp any) + (-> sexp term-node? any)) (lambda (x) #t)] [#:pp pp (or/c (any -> string) (any output-port number (is-a?/c text%) -> void)) default-pretty-printer] - [#:colors colors (listof (list string string)) '()]) + [#:colors colors + (listof + (cons/c string + (and/c (listof (or/c string? (is-a?/c color%))) + (lambda (x) (member (length x) '(2 3 4 6))))))] + + [#:scheme-colors? scheme-colors? boolean?] + [#:layout layout (-> (listof term-node?) void)]) void?]{ This function opens a new window and inserts each expression @@ -1163,14 +1171,56 @@ final argument is the text where the port is connected -- characters written to the port go to the end of the editor. The @scheme[colors] argument, if provided, specifies a list of -reduction-name/color-string pairs. The traces gui will color -arrows drawn because of the given reduction name with the -given color instead of using the default color. +reduction-name/color-list pairs. The traces gui will color arrows +drawn because of the given reduction name with the given color instead +of using the default color. + +The @scheme[cdr] of each of the elements of @scheme[colors] is a list +of colors, organized in pairs. The first two colors cover the colors +of the line and the border around the arrow head, the first when the +mouse is over a graph node that is connected to that arrow, and the +second for when the mouse is not over that arrow. Similarly, the next +colors are for the text drawn on the arrow and the last two are for +the color that fills the arrow head. If fewer than six colors are +specified, the colors specified colors are used and then defaults are +filled in for the remaining colors. + + + +The @scheme[scheme-colors?] argument, if @scheme[#t] causes +@scheme[traces] to color the contents of each of the windows according +to DrScheme's Scheme mode color Scheme. If it is @scheme[#f], +@scheme[traces] just uses black for the color scheme. + +The @scheme[layout] argument is called (with all of the terms) each +time a new term is inserted into the window. See also +@scheme[term-node-set-position!]. You can save the contents of the window as a postscript file from the menus. } +@defproc[(traces/ps [reductions reduction-relation?] + [expr (or/c any/c (listof any/c))] + [file (or/c path-string? path?)] + [#:multiple? multiple? boolean? #f] + [#:pred pred + (or/c (-> sexp any) + (-> sexp term-node? any)) + (lambda (x) #t)] + [#:pp pp + (or/c (any -> string) + (any output-port number (is-a?/c text%) -> void)) + default-pretty-printer] + [#:colors colors (listof (list string string)) '()] + [#:layout layout (-> (listof term-node?) void)]) + void?]{ + +The arguments behave just like the function @scheme[traces], but +instead of opening a window to show the reduction graph, it just saves +the reduction graph to the specified @scheme[file]. +} + @defproc[(stepper [reductions reduction-relation?] [t any/c] [pp (or/c (any -> string) @@ -1246,6 +1296,24 @@ not colored specially. Returns the expression in this node. } +@defproc[(term-node-set-position! [tn term-node?] [x (and/c real? positive?)] [y (and/c real? positive?)]) void?]{ + +Sets the position of @scheme[tn] in the graph to (@scheme[x],@scheme[y]). +} + +@defproc[(term-node-x [tn term-node?]) real]{ +Returns the @tt{x} coordinate of @scheme[tn] in the window. +} +@defproc[(term-node-y [tn term-node?]) real]{ +Returns the @tt{y} coordinate of @scheme[tn] in the window. +} +@defproc[(term-node-width [tn term-node?]) real]{ +Returns the width of @scheme[tn] in the window. +} +@defproc[(term-node-height [tn term-node?]) real?]{ +Returns the height of @scheme[tn] in the window. +} + @defproc[(term-node? [v any/c]) boolean?]{ Recognizes term nodes.