diff --git a/collects/redex/pict.ss b/collects/redex/pict.ss index 41dc82b83c..519ae2ab3f 100644 --- a/collects/redex/pict.ss +++ b/collects/redex/pict.ss @@ -83,4 +83,6 @@ [set-arrow-pict! (-> symbol? (-> pict?) void?)] [lw->pict + (-> (or/c (listof symbol?) compiled-lang?) lw? pict?)] + [render-lw (-> (or/c (listof symbol?) compiled-lang?) lw? pict?)]) \ No newline at end of file diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss index eb2edaf4a5..7b91078e4c 100644 --- a/collects/redex/private/bitmap-test.ss +++ b/collects/redex/private/bitmap-test.ss @@ -1,7 +1,6 @@ (module bitmap-test mzscheme (require "bitmap-test-util.ss" - "../pict.ss" - "../reduction-semantics.ss") + "../main.ss") ;; tests: ;; - language, @@ -40,5 +39,12 @@ (test (render-metafunction S) "metafunction.png") + ;; in this test, teh `x' is italic and the 'z' is sf, since 'x' is in the grammar, and 'z' is not. + (test (render-lw + lang + (to-lw ((λ (x) (x x)) + (λ (z) (z z))))) + "lw.png") + (printf "bitmap-test.ss: ") (done)) diff --git a/collects/redex/private/bmps/lw.png b/collects/redex/private/bmps/lw.png new file mode 100644 index 0000000000..19acca0dfa Binary files /dev/null and b/collects/redex/private/bmps/lw.png differ diff --git a/collects/redex/private/core-layout.ss b/collects/redex/private/core-layout.ss index e35dd286b0..4476b1c3e2 100644 --- a/collects/redex/private/core-layout.ss +++ b/collects/redex/private/core-layout.ss @@ -1,16 +1,19 @@ +#lang scheme/base -(module core-layout mzscheme - (require "loc-wrapper.ss" - "matcher.ss" - "reduction-semantics.ss" - (lib "list.ss") - (lib "utils.ss" "texpict") - (lib "mrpict.ss" "texpict") - (lib "etc.ss") - (lib "mred.ss" "mred") - (lib "struct.ss")) +(require "loc-wrapper.ss" + "matcher.ss" + "reduction-semantics.ss" + + texpict/utils + texpict/mrpict + + scheme/gui/base + scheme/class) + +(require (for-syntax scheme/base)) (provide find-enclosing-loc-wrapper + render-lw lw->pict basic-text metafunction-text @@ -36,10 +39,10 @@ ;; for test suite build-lines - (struct token (column span)) - (struct string-token (string style)) - (struct pict-token (pict)) - (struct spacer-token ()) + (struct-out token) + (struct-out string-token) + (struct-out pict-token) + (struct-out spacer-token) current-text) @@ -117,25 +120,29 @@ ;; token = string-token | spacer-token | pict-token | align-token - (define-struct token (column span) (make-inspector)) + (define-struct token (column span) #:inspector (make-inspector)) ;; string : string ;; style : valid third argument to mrpict.ss's `text' function - (define-struct (string-token token) (string style) (make-inspector)) + (define-struct (string-token token) (string style) #:inspector (make-inspector)) ;; width : number ;; pict : pict - (define-struct (pict-token token) (pict) (make-inspector)) + (define-struct (pict-token token) (pict) #:inspector (make-inspector)) ;; spacer : number - (define-struct (spacer-token token) () (make-inspector)) + (define-struct (spacer-token token) () #:inspector (make-inspector)) ;; pict : pict ;; this token always appears at the beginning of a line and its width ;; is the x-coordinate of the pict inside itself (which must appear on ;; an earlier line) - (define-struct align-token (pict) (make-inspector)) + (define-struct align-token (pict) #:inspector (make-inspector)) + (define (render-lw nts lw) + (parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))]) + (lw->pict nts lw))) + (define (lw->pict nts lw) (lines->pict (setup-lines @@ -156,13 +163,13 @@ ((current-unquote-rewriter) w-out-term-let) w-out-term-let)]) (if (equal? rewritten an-lw) - (copy-struct lw + (struct-copy lw an-lw - [lw-e (ar/e (lw-e an-lw) - (lw-line an-lw) - (lw-line-span an-lw) - (lw-column an-lw) - (lw-column-span an-lw))]) + [e (ar/e (lw-e an-lw) + (lw-line an-lw) + (lw-line-span an-lw) + (lw-column an-lw) + (lw-column-span an-lw))]) (ar/lw rewritten)))])) (define (remove-term-let an-lw) @@ -172,9 +179,9 @@ (pair? (cdr content)) (lw? (cadr content)) (equal? 'term-let (lw-e (cadr content)))) - (copy-struct lw + (struct-copy lw an-lw - [lw-e (lw-e (second-to-last content))]) + [e (lw-e (second-to-last content))]) an-lw)) an-lw)) @@ -755,6 +762,4 @@ [else (for-each find/lw e)])) (find/e in-lws) - lws) - - ) + lws) \ No newline at end of file diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss index f12b13c814..3dcd143e28 100644 --- a/collects/redex/private/pict.ss +++ b/collects/redex/private/pict.ss @@ -37,7 +37,7 @@ linebreaks just-before - just-after + just-after rule-pict-style arrow-space diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index d8b92673bb..8d8f60f8ac 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1152,12 +1152,15 @@ This section documents two classes of operations, one for direct use of creating postscript figures for use in papers and for use in DrScheme to easily adjust the typesetting: @scheme[render-language], -@scheme[render-reduction-relation], and -@scheme[render-metafunction], and one +@scheme[render-reduction-relation], +@scheme[render-metafunction], and +@scheme[render-lw], +and one for use in combination with other libraries that operate on picts @scheme[language->pict], -@scheme[reduction-relation->pict], and -@scheme[metafunction->pict]. +@scheme[reduction-relation->pict], +@scheme[metafunction->pict], and +@scheme[lw->pict]. The primary difference between these functions is that the former list sets @scheme[dc-for-text-size] and the latter does not. @@ -1622,6 +1625,30 @@ the empty string and the @scheme[x] in the typeset output. } +@defproc[(render-lw (language/nts (or/c (listof symbol?) compiled-lang?)) + (lw lw?)) pict?]{ + + Produces a pict that corresponds to the @scheme[lw] object + argument, using @scheme[language/nts] to determine which + of the identifiers in the @scheme[lw] argument are + non-terminals. + + This function sets @scheme[dc-for-text-size]. See also + @scheme[lw->pict]. +} + +@defproc[(lw->pict (language/ntw (or/c (listof symbol?) compiled-lang?)) + (lw lw?)) pict?]{ + + Produces a pict that corresponds to the @scheme[lw] object + argument, using @scheme[language/nts] to determine which + of the identifiers in the @scheme[lw] argument are + non-terminals. + + This does not set the @scheme[dc-for-text-size] parameter. See also + @scheme[render-lw]. +} + @deftogether[[ @defproc[(just-before [stuff (or/c pict? string? symbol?)] [lw lw?])