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

PR 10042

Browse Source 
svn: r13444
This commit is contained in:
Robby Findler 2009-02-05 01:14:37 +00:00
parent 7eaef08d63
commit 4f2070831b
5 changed files with 96 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/redex/pict.ss
View File

@ -68,7 +68,9 @@
[label-space (parameter/c natural-number/c)] [label-space (parameter/c natural-number/c)]
[metafunction-pict-style [metafunction-pict-style
(parameter/c (symbols 'left-right (parameter/c (symbols 'left-right
'up-down))]) 'left-right/vertical-side-conditions
'up-down
'up-down/vertical-side-conditions))])
(provide/contract (provide/contract
[label-font-size (parameter/c (and/c (between/c 1 255) integer?))] [label-font-size (parameter/c (and/c (between/c 1 255) integer?))]

5
collects/redex/private/bitmap-test.ss
View File

@ -87,5 +87,10 @@
;; all show up in the output. ;; all show up in the output.
(test (render-metafunction Name) "metafunction-Name.png") (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: ") (printf "bitmap-test.ss: ")
(done) (done)

BIN
collects/redex/private/bmps/metafunction-Name-vertical.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.7 KiB

20
collects/redex/private/pict.ss
View File

@ -651,10 +651,11 @@
(define metafunction->pict/proc (define metafunction->pict/proc
(lambda (mf) (lambda (mf)
(let ([current-linebreaks (linebreaks)] (let* ([current-linebreaks (linebreaks)]
[all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))] [all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))]
[sep 2]) [sep 2]
(let* ([wrapper->pict (lambda (lw) (lw->pict all-nts lw))] [style (metafunction-pict-style)]
[wrapper->pict (lambda (lw) (lw->pict all-nts lw))]
[eqns (metafunc-proc-pict-info (metafunction-proc mf))] [eqns (metafunc-proc-pict-info (metafunction-proc mf))]
[lhss (map (lambda (eqn) [lhss (map (lambda (eqn)
(wrapper->pict (wrapper->pict
@ -672,7 +673,10 @@
(cons (wrapper->pict (car p)) (cons (wrapper->pict (car p))
(wrapper->pict (cdr p)))) (wrapper->pict (cdr p))))
(list-ref eqn 2)) (list-ref eqn 2))
+inf.0))) (if (memq style '(up-down/vertical-side-conditions
left-right/vertical-side-conditions))
0
+inf.0))))
eqns)] eqns)]
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)] [rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)]
[linebreak-list (or current-linebreaks [linebreak-list (or current-linebreaks
@ -690,8 +694,8 @@
(+ (pict-width lhs) (pict-width rhs) (pict-width =-pict) (+ (pict-width lhs) (pict-width rhs) (pict-width =-pict)
(* 2 sep))))) (* 2 sep)))))
lhss scs rhss linebreak-list))]) lhss scs rhss linebreak-list))])
(case (metafunction-pict-style) (case style
[(left-right) [(left-right left-right/vertical-side-conditions)
(table 3 (table 3
(apply append (apply append
(map (lambda (lhs sc rhs linebreak?) (map (lambda (lhs sc rhs linebreak?)
@ -722,7 +726,7 @@
linebreak-list)) linebreak-list))
ltl-superimpose ltl-superimpose ltl-superimpose ltl-superimpose
sep sep)] sep sep)]
[(up-down) [(up-down up-down/vertical-side-conditions)
(apply vl-append (apply vl-append
sep sep
(apply append (apply append
@ -734,7 +738,7 @@
(list (inset sc 0 0 (- 5 (pict-width sc)) 0))))) (list (inset sc 0 0 (- 5 (pict-width sc)) 0)))))
lhss lhss
scs scs
rhss)))]))))) rhss)))]))))
(define (metafunction-call name an-lw flattened?) (define (metafunction-call name an-lw flattened?)
(if flattened? (if flattened?

2
collects/redex/redex.scrbl
View File

@ -1636,7 +1636,7 @@ label on each rule, but only in horizontal mode. Defaults to
0. 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 This parameter controls the style used for typesetting
metafunctions. The 'left-right style means that the metafunctions. The 'left-right style means that the