From 4f2070831bd1d66e85b476028eb6ea11da34d522 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 5 Feb 2009 01:14:37 +0000 Subject: [PATCH] PR 10042 svn: r13444 --- collects/redex/pict.ss | 4 +- collects/redex/private/bitmap-test.ss | 5 + .../bmps/metafunction-Name-vertical.png | Bin 0 -> 4793 bytes collects/redex/private/pict.ss | 170 +++++++++--------- collects/redex/redex.scrbl | 2 +- 5 files changed, 96 insertions(+), 85 deletions(-) create mode 100644 collects/redex/private/bmps/metafunction-Name-vertical.png diff --git a/collects/redex/pict.ss b/collects/redex/pict.ss index 4963c707cd..5c98b71643 100644 --- a/collects/redex/pict.ss +++ b/collects/redex/pict.ss @@ -68,7 +68,9 @@ [label-space (parameter/c natural-number/c)] [metafunction-pict-style (parameter/c (symbols 'left-right - 'up-down))]) + 'left-right/vertical-side-conditions + 'up-down + 'up-down/vertical-side-conditions))]) (provide/contract [label-font-size (parameter/c (and/c (between/c 1 255) integer?))] diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/private/bitmap-test.ss index b327dc1a98..979014f678 100644 --- a/collects/redex/private/bitmap-test.ss +++ b/collects/redex/private/bitmap-test.ss @@ -87,5 +87,10 @@ ;; all show up in the output. (test (render-metafunction Name) "metafunction-Name.png") +;; same as previous, but with vertical organization of the bindings +(test (parameterize ([metafunction-pict-style 'up-down/vertical-side-conditions]) + (render-metafunction Name)) + "metafunction-Name-vertical.png") + (printf "bitmap-test.ss: ") (done) diff --git a/collects/redex/private/bmps/metafunction-Name-vertical.png b/collects/redex/private/bmps/metafunction-Name-vertical.png new file mode 100644 index 0000000000000000000000000000000000000000..cffd3e9f29060a58b2f9bce1e90afd087df4c997 GIT binary patch literal 4793 zcmW+)2RPLKAOBjpWSmh}W{6T*KO*BoX4x})#0f{p-glWNosm6`Bzt6JlZ@yx%gW9; zbP)*||4;wV^W1&!dG7mszMuDajrTWJPe+}OhJyxzAUaJARReJK2OljMIru)SqrL(` zOyQcUca8kBe^|O08LD&UVlV?fI!C#%19GY~Kj_+C8@i*HTQaUSt^=f=- zO7?zz=-!C>b(8Y`{{HH>Z&lQ^wFkw%JX=guI=$^j%C4+LnVGRkEG;cXwHVNKioYw5#zQ&ZDDdis7ca)g$E&Nwz|9bp*k{om+!PzDi9mGLyG}@>zQv>>c;PV0$U1T5 zaCm8Hsr5TgJ|Q7BUEQj}LJDR7KO`#%s;#J~So@rlm6a8=vvf}=IU^(EJRde8p=gY_ zzrQ~pcGeahO`W47BPJFTA0Lm!QbO`U`?SjGFJGz^k9Bu7$c#a&EXIV28o&QBl2Xd13T?mMy*&B_$<#!WfU`&IpR>>1pSo+_tc@_Tu8TBtdPx z=9ZS0=g*(l)I13eZZ#8asIK<(@wu<7`)7C8(8NSqQnFjitif&SWAfFa1YB1~1c^wj zsjfcwHFyhel;30j1c5*p8(;io-4WWBn8<(;la_v|RrKpH7`FJcxT1eic@ z+1a#w;}a9}%}=inOwP?!zIl_LoQ%HtmsScRcI66MLjdIeny~OO*t#u?lax!g$b6r?eR7yg^z|c^ISXo&Ka^JJ-1v;rP zT8#tT@BeFnO7kePdog%_%6ao^#Y{(-l2!zKdS+%~Vj?IYpsA@zUzjBV5sn%m`Vd8UAvkPgWJF(Ie|MGewzf7CwCmCD z%^IxPORzMPh3ts;g$z+eFr#b6rlzdLyS8_eniT!F^J{8$K#50IPX7MMQw$kc@v5(@ zgCIZBw=UW6>M1uWDk^H~=*~_=3dq2#;$j)k%FT%?XD6qq=xB9y^;_1hlcS?a-HV>L zFZ-AZFmc`Sbvrvf;goiRAj@W-k|E`~`g&$2CRKjMSXFXJKIDi+7fl9%T~AL>C1Tao z)L3s>e=vU!y`Ymqcg4iTz0YNl$PmS8e6SaX7WRM408EoeB>w@yYm&O^Gp)6vk-(9_Q~df42(+XbQq=zf!*A1(_ZNJaIGL_$G`2M-7l6x0x8 zU&BVlf=){_MIzTpvn?trDm;q8{u|>W*+V5boW8w%!To}yB&OWfUu0+Ov^6LT(MvPa z(~)6LTyt}CAa5!v=k0S+X6No+fkso{ zG>r81?P|>a1y{Q6EoRw>;>seRTwT%dmuYEZ$h!4)WCougAD`XQhgdgh3o9#yD_2wu z4adHGxv0EOBApUs=50~z?CgfcI>vf>09$hn?pgKq|M|K~IdggG8yg#2StV>89UblO z`(_tu3ozYG`@6lUvX^DI?(sE(nv09;-o1MuUS(kx8dq1>N0%|me2IN%I1ME^Y_SVX zZCYs=JIhspVBV4c?Isc#JV@{<0x;d!*!WpG8X+zh!OiaDXPu%&T^lutZcVwsJHjqq@>Y!)?4ScKMo9B6A=-) zd9&T`C$|mzE~u(2E7UjK$JIP&iyj zP>>5qi1NXY#`)%V@1$g8RA7LWtSl|zrqPShJfYkB`)apnqW+q7ag-fEH<{qFc+uBZMTl`o>&1{j#cMg5e zJI+pL1_$E_P5_>4gw3Le$!7%x1*Zcx?ZL9CT3;q6lzg|+Rr#Oz`l38MsF`9_ZEVg~ z2Giiw`iBQQ4*vi{hw+@MeFTLA%-w|n#4%oE=j7Bb908|glzEk(?+IjVQt8pP2Oi2W z)|-|{H@D!^5iNnYO0n>nGFtyGciSyKfvpW#f^UZCNCs(ZeKS;Yb;AQSDp+y-kn&VH#auUy}mCV_!cmbR?+F+m@X1ujK@a|txbIWT07-NBTsh86){#OiZ7+xQI(nM>;qx z10DMQ{rlRQDPVhZ^Vq}w;bH{$qqsw0Tmb6bd^PxSK)6S*a>;vMptkV%shy#FRU!kM zdg~+tolN5-krAwz=V)&~3K|XGyH#b4@W4ae<#awzc zGjy_~fnT{HDvIs0g`mfeA6Htp#kslkyD!>qre2WC;bvw=TiM(7m@DQDfjEVL71J*n zZ*G>`mewb3ZM8ZPI5MKSQY)*f@-j0w78W4L)5}W^*ud!MK8UVIcntW!&!0c1r>6rg zo#XlD4OCY?;MZJR5YS5-;4e_K&A^U*aIx(iQ|3tMUEUF3I{!H^8cQ}%Jc6vRukWvD zX!trh%7lOcZ#1HOnY(~V`JKy{kX+95sFJ!mDX25~s_yU&mm`)0StMhv(tuIaThi7MJ$H%4KfHR&Bc(}MQ z(meB+Yu(x1MYHi(nVAU_PQp6x+yw&U>FEj77_)7&U)kK8saA*={K4RV)qj601NfWF zN3BCr#B}n?i!T`tejdQr8Q=4ggPjuybV|0>ot*0h1^kkdZ!s8*ojW0jwlyMGF{C*s zXSP~;<)oLlnLeXx(JvA=qPnb}XTR+_Q3+hKb(2@m=xA+S9gFfik9kFJ@7;ji)!8O* z=aGVYRW=M9b*x^FgiM*HH7~Da5%8gW3#hX0!)X8htHy-Ds4Kf zfnW^{G2oiMeE9-I05IfSwH-xbpR2pOg6BeKwyZZ`_w@Tt*4DXL^rw_iN2!s6kzzJ^ zaq%YuDI&Dz9L8Qh06GHN&QT&`XJ-ervzs(9eW$-CY`nBXwM$qyIGQ~dm0@@UZ~hoj zH&5{ye06QDFy`;!p{$&ow6wH|u`weIv$SLnTP(O2Km305_;43k7m-Wxz;nPWvQtxg zmUkR42R7PLN{ztt_M4Q%Z!>-8Q&bmbxpw{f6|&nH`1!~k%A*?r`5hf+TT^cVv%E0^ z*6?v)U~^H?BOM(bRaHtaFu@r9e>v2crKYC3ySobt3TgzFmX})^7$^%c0V6JSKRx`Q z6--F%(Q{Sf{m6nHWF9pf?dsx!PbJ$kE%YUaEG;d+`*A=J`+vZegGEfeZYrdc4ZsG5 zk>|O0i8)VTjuPeqOyChfB%-6E2c=k(!}p29oLBN=dkaINPU5@3f4Gt9X&R`rL0X)R zHe1fge2P?RTz1p)o$cet9L&tgK$N+;Nz2P)HcnvZ0@F%m<;^{9;J*z^jGE}p3K`YZ zm=o0hV%2G%qfU-CtE{c9p>U{gIhRweU%MvEqUGr52&52&x|yJsOf0l`_%M`6#UextJh-C- zJ8l6uU>~`YFNFfERMo(GfO_h}-EW0F7$AU}rY=2MfC?*e~6hB|>q z&`*`1mw1|h72;4jVnGj5W)7}+-M-8e`>M1waC_k{ga`h$POx z>X=vW<>4enukx~<=`$+`_g_Q<{`2+oyOQ}&PqnnP-q^w4Z*93{G*VLB)7u+NYG9onEGLdQX*c=L$DH9^3P2MhrKaeT5bNdZyAP6N-Rdt+Pp;tW_zq1lHZ<(E zuc5hcfo%Q1L~c9m9d?rK8RFHCTcVSapN;abbSeur-# zJ-c3fzRPxkK<@~3Q>n;N+wD;(kR0FHYOL{Mz4BLbk!Kl zHmBEbKE&C|Ic&lM=U+c9p zpg815Wm~s4;t-Z~mhZXv{uv#o^j?5#`CGrj7D8BcacZSi%l_%f-;g+TIULRkYZ7dhs(}HFrtHfB|4L4)~N%*ZGA(dT)>w8-T$Ex_^df|m?$GI&IqGiSy=(I zGpict/proc (lambda (mf) - (let ([current-linebreaks (linebreaks)] - [all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))] - [sep 2]) - (let* ([wrapper->pict (lambda (lw) (lw->pict all-nts lw))] - [eqns (metafunc-proc-pict-info (metafunction-proc mf))] - [lhss (map (lambda (eqn) - (wrapper->pict - (metafunction-call (metafunc-proc-name (metafunction-proc mf)) - (list-ref eqn 0) - (metafunc-proc-multi-arg? (metafunction-proc mf))))) - eqns)] - [scs (map (lambda (eqn) - (if (and (null? (list-ref eqn 1)) - (null? (list-ref eqn 2))) - #f - (side-condition-pict null - (map wrapper->pict (list-ref eqn 1)) - (map (lambda (p) - (cons (wrapper->pict (car p)) - (wrapper->pict (cdr p)))) - (list-ref eqn 2)) - +inf.0))) - eqns)] - [rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)] - [linebreak-list (or current-linebreaks - (map (lambda (x) #f) eqns))] - [=-pict (make-=)] - [max-lhs-w (apply max (map pict-width lhss))] - [max-line-w (apply - max - (map (lambda (lhs sc rhs linebreak?) - (max - (if sc (pict-width sc) 0) - (if linebreak? - (max (pict-width lhs) - (+ (pict-width rhs) (pict-width =-pict))) - (+ (pict-width lhs) (pict-width rhs) (pict-width =-pict) - (* 2 sep))))) - lhss scs rhss linebreak-list))]) - (case (metafunction-pict-style) - [(left-right) - (table 3 - (apply append - (map (lambda (lhs sc rhs linebreak?) - (append - (if linebreak? - (list lhs (blank) (blank)) - (list lhs =-pict rhs)) - (if linebreak? - (let ([p rhs]) - (list (hbl-append sep - =-pict - (inset p 0 0 (- 5 (pict-width p)) 0)) - (blank) - ;; n case this line sets the max width, add suitable space in the right: - (blank (max 0 (- (pict-width p) max-lhs-w sep)) - 0))) - null) - (if (not sc) - null - (list (inset sc 0 0 (- 5 (pict-width sc)) 0) + (let* ([current-linebreaks (linebreaks)] + [all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))] + [sep 2] + [style (metafunction-pict-style)] + [wrapper->pict (lambda (lw) (lw->pict all-nts lw))] + [eqns (metafunc-proc-pict-info (metafunction-proc mf))] + [lhss (map (lambda (eqn) + (wrapper->pict + (metafunction-call (metafunc-proc-name (metafunction-proc mf)) + (list-ref eqn 0) + (metafunc-proc-multi-arg? (metafunction-proc mf))))) + eqns)] + [scs (map (lambda (eqn) + (if (and (null? (list-ref eqn 1)) + (null? (list-ref eqn 2))) + #f + (side-condition-pict null + (map wrapper->pict (list-ref eqn 1)) + (map (lambda (p) + (cons (wrapper->pict (car p)) + (wrapper->pict (cdr p)))) + (list-ref eqn 2)) + (if (memq style '(up-down/vertical-side-conditions + left-right/vertical-side-conditions)) + 0 + +inf.0)))) + eqns)] + [rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)] + [linebreak-list (or current-linebreaks + (map (lambda (x) #f) eqns))] + [=-pict (make-=)] + [max-lhs-w (apply max (map pict-width lhss))] + [max-line-w (apply + max + (map (lambda (lhs sc rhs linebreak?) + (max + (if sc (pict-width sc) 0) + (if linebreak? + (max (pict-width lhs) + (+ (pict-width rhs) (pict-width =-pict))) + (+ (pict-width lhs) (pict-width rhs) (pict-width =-pict) + (* 2 sep))))) + lhss scs rhss linebreak-list))]) + (case style + [(left-right left-right/vertical-side-conditions) + (table 3 + (apply append + (map (lambda (lhs sc rhs linebreak?) + (append + (if linebreak? + (list lhs (blank) (blank)) + (list lhs =-pict rhs)) + (if linebreak? + (let ([p rhs]) + (list (hbl-append sep + =-pict + (inset p 0 0 (- 5 (pict-width p)) 0)) (blank) - ;; In case sc set the max width... - (blank (max 0 (- (pict-width sc) max-lhs-w (pict-width =-pict) (* 2 sep))) - 0))))) - lhss - scs - rhss - linebreak-list)) - ltl-superimpose ltl-superimpose - sep sep)] - [(up-down) - (apply vl-append - sep - (apply append - (map (lambda (lhs sc rhs) - (cons - (vl-append (hbl-append lhs =-pict) rhs) - (if (not sc) - null - (list (inset sc 0 0 (- 5 (pict-width sc)) 0))))) - lhss - scs - rhss)))]))))) + ;; n case this line sets the max width, add suitable space in the right: + (blank (max 0 (- (pict-width p) max-lhs-w sep)) + 0))) + null) + (if (not sc) + null + (list (inset sc 0 0 (- 5 (pict-width sc)) 0) + (blank) + ;; In case sc set the max width... + (blank (max 0 (- (pict-width sc) max-lhs-w (pict-width =-pict) (* 2 sep))) + 0))))) + lhss + scs + rhss + linebreak-list)) + ltl-superimpose ltl-superimpose + sep sep)] + [(up-down up-down/vertical-side-conditions) + (apply vl-append + sep + (apply append + (map (lambda (lhs sc rhs) + (cons + (vl-append (hbl-append lhs =-pict) rhs) + (if (not sc) + null + (list (inset sc 0 0 (- 5 (pict-width sc)) 0))))) + lhss + scs + rhss)))])))) (define (metafunction-call name an-lw flattened?) (if flattened? diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index c79e650b06..4b8a0d77db 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1636,7 +1636,7 @@ label on each rule, but only in horizontal mode. Defaults to 0. } -@defparam[metafunction-pict-style style (parameter/c (symbols 'left-right 'up-down))]{ +@defparam[metafunction-pict-style style (parameter/c (symbols 'left-right 'up-down 'left-right/vertical-side-conditions 'up-down/vertical-side-conditions))]{ This parameter controls the style used for typesetting metafunctions. The 'left-right style means that the