From 070b321558b1f07966f1c6906c6581a6e052d04e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 14 Aug 2008 21:22:26 +0000 Subject: [PATCH] added render-lw svn: r11255 --- collects/redex/pict.ss | 2 + collects/redex/private/bitmap-test.ss | 10 +++- collects/redex/private/bmps/lw.png | Bin 0 -> 1237 bytes collects/redex/private/core-layout.ss | 65 ++++++++++++++------------ collects/redex/private/pict.ss | 2 +- collects/redex/redex.scrbl | 35 ++++++++++++-- 6 files changed, 77 insertions(+), 37 deletions(-) create mode 100644 collects/redex/private/bmps/lw.png 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 0000000000000000000000000000000000000000..19acca0dfa687f1bc38a338c5bac941bea31bc3a GIT binary patch literal 1237 zcmV;`1SNklxA_Ckk(An8;Wdx5${5J(+@ zvJy%PG7y5IjI1a@!R&>K(sk!|82-yRv%Bv0^11jlJkO&uvl`zF2qE~Ncs#DrXn6hc z@xd?*!!SSwcoy;b`I$CLr=-C<<@6&|=!Iq3+1c4dB7y6np`pUULbuy3U4dtDE-o%S z9*@$LGCjbz_ zrKKf@!-4+BHH0vcNMvVc@9pi0>o=a2!`rQE_u~gEG8E zpy#2ht4r+t2tSS0YMq*zQks$m@1*-_RH0Dl?(VL%v=jhqS0t{xm=HrkMyIC z`&pJ{CNrZgqLlkOL|$@lm7WHO01jB5bE z%F2pXt8Hm%F`LbEb93|o5qMKnv&m1_tU7VtE;2YD9f?{ z09*qA78e)IW-|bwv$Hc02zb3-B24%J08dX(S65fKCl-s9l$0n<;YfGV{Q{dTFE3{p zCK8DN0C0VFc6NMx+}+&`04OLZFdB^xha(=3<6+zn06022G8haRjpqFPoc~ziaJas{ zUTKOaZ71C?ut~LAZL`^YJ|6%8*9!{^4Gj%dRaMA0K0faA`9?=a@i6cAcsxx_P4DmT zwY9ZvZEbeDo#QynYBGg?U|lV4w7 zNIyJ0SS%K$DW0^QV*LaFy_}w&E-x?BS`K3VXf$fITIrAey?3EIrTcLJuR@_vEEc1+ z90dKRr>BWTLTO4GyfbY-PX@%M5S*V+A&9@2Ma25Ww2F@X))a#Hi&;dhUvx$xZuWPl z5X4{1B4Yi5n%v~Krx1_F^It04+uO*Kb{3Jy^2qEL)atRZG5+cygzfF^larHqd3k7M ze}8{|e*Ww0tG&IQepGNjgfKTZSFhLW_4;5iczAedv)Qy-EdU@RBg60a2LgfS=4Pc? z+%KnJP^aAF{r!DrW+wh{S}Yc$(U_H$6^%yeYoz@ULcib7FwD%%48G`aI7}wf_p$_O z`)QrB$)8UlPft(f<>h9xnQ+RPMZ~g7`)Qr>>-xhf1VU)BSaNc5oK7d;{ zX#6|^fq+V-;{U@oHZ~3q4?_qek%(HYJ~%ia&X4d#F5zTc9+WqAsiSO zXlQ8Q*H2DPii(N`2M5LcX!67vA0Ov!t*x!}gCH}Dkl#;ha+BYlLL^8#i~JC=xrEo` zCgJZ*A&9@2Ma25Ww7@3eFHIqcznDeD`o;7=61n+{!Q^)T00000NkvXXu0mjfjf!4$ literal 0 HcmV?d00001 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?])