PR 10042
svn: r13444
This commit is contained in:
Robby Findler
parent
7eaef08d63
commit
4f2070831b
|
|
@ -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?))]
|
||||||
|
|
|
||||||
|
|
@ -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
BIN
collects/redex/private/bmps/metafunction-Name-vertical.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 4.7 KiB |
|
|
@ -651,90 +651,94 @@
|
||||||
|
|
||||||
(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)]
|
||||||
[eqns (metafunc-proc-pict-info (metafunction-proc mf))]
|
[wrapper->pict (lambda (lw) (lw->pict all-nts lw))]
|
||||||
[lhss (map (lambda (eqn)
|
[eqns (metafunc-proc-pict-info (metafunction-proc mf))]
|
||||||
(wrapper->pict
|
[lhss (map (lambda (eqn)
|
||||||
(metafunction-call (metafunc-proc-name (metafunction-proc mf))
|
(wrapper->pict
|
||||||
(list-ref eqn 0)
|
(metafunction-call (metafunc-proc-name (metafunction-proc mf))
|
||||||
(metafunc-proc-multi-arg? (metafunction-proc mf)))))
|
(list-ref eqn 0)
|
||||||
eqns)]
|
(metafunc-proc-multi-arg? (metafunction-proc mf)))))
|
||||||
[scs (map (lambda (eqn)
|
eqns)]
|
||||||
(if (and (null? (list-ref eqn 1))
|
[scs (map (lambda (eqn)
|
||||||
(null? (list-ref eqn 2)))
|
(if (and (null? (list-ref eqn 1))
|
||||||
#f
|
(null? (list-ref eqn 2)))
|
||||||
(side-condition-pict null
|
#f
|
||||||
(map wrapper->pict (list-ref eqn 1))
|
(side-condition-pict null
|
||||||
(map (lambda (p)
|
(map wrapper->pict (list-ref eqn 1))
|
||||||
(cons (wrapper->pict (car p))
|
(map (lambda (p)
|
||||||
(wrapper->pict (cdr p))))
|
(cons (wrapper->pict (car p))
|
||||||
(list-ref eqn 2))
|
(wrapper->pict (cdr p))))
|
||||||
+inf.0)))
|
(list-ref eqn 2))
|
||||||
eqns)]
|
(if (memq style '(up-down/vertical-side-conditions
|
||||||
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)]
|
left-right/vertical-side-conditions))
|
||||||
[linebreak-list (or current-linebreaks
|
0
|
||||||
(map (lambda (x) #f) eqns))]
|
+inf.0))))
|
||||||
[=-pict (make-=)]
|
eqns)]
|
||||||
[max-lhs-w (apply max (map pict-width lhss))]
|
[rhss (map (lambda (eqn) (wrapper->pict (list-ref eqn 3))) eqns)]
|
||||||
[max-line-w (apply
|
[linebreak-list (or current-linebreaks
|
||||||
max
|
(map (lambda (x) #f) eqns))]
|
||||||
(map (lambda (lhs sc rhs linebreak?)
|
[=-pict (make-=)]
|
||||||
(max
|
[max-lhs-w (apply max (map pict-width lhss))]
|
||||||
(if sc (pict-width sc) 0)
|
[max-line-w (apply
|
||||||
(if linebreak?
|
max
|
||||||
(max (pict-width lhs)
|
(map (lambda (lhs sc rhs linebreak?)
|
||||||
(+ (pict-width rhs) (pict-width =-pict)))
|
(max
|
||||||
(+ (pict-width lhs) (pict-width rhs) (pict-width =-pict)
|
(if sc (pict-width sc) 0)
|
||||||
(* 2 sep)))))
|
(if linebreak?
|
||||||
lhss scs rhss linebreak-list))])
|
(max (pict-width lhs)
|
||||||
(case (metafunction-pict-style)
|
(+ (pict-width rhs) (pict-width =-pict)))
|
||||||
[(left-right)
|
(+ (pict-width lhs) (pict-width rhs) (pict-width =-pict)
|
||||||
(table 3
|
(* 2 sep)))))
|
||||||
(apply append
|
lhss scs rhss linebreak-list))])
|
||||||
(map (lambda (lhs sc rhs linebreak?)
|
(case style
|
||||||
(append
|
[(left-right left-right/vertical-side-conditions)
|
||||||
(if linebreak?
|
(table 3
|
||||||
(list lhs (blank) (blank))
|
(apply append
|
||||||
(list lhs =-pict rhs))
|
(map (lambda (lhs sc rhs linebreak?)
|
||||||
(if linebreak?
|
(append
|
||||||
(let ([p rhs])
|
(if linebreak?
|
||||||
(list (hbl-append sep
|
(list lhs (blank) (blank))
|
||||||
=-pict
|
(list lhs =-pict rhs))
|
||||||
(inset p 0 0 (- 5 (pict-width p)) 0))
|
(if linebreak?
|
||||||
(blank)
|
(let ([p rhs])
|
||||||
;; n case this line sets the max width, add suitable space in the right:
|
(list (hbl-append sep
|
||||||
(blank (max 0 (- (pict-width p) max-lhs-w sep))
|
=-pict
|
||||||
0)))
|
(inset p 0 0 (- 5 (pict-width p)) 0))
|
||||||
null)
|
|
||||||
(if (not sc)
|
|
||||||
null
|
|
||||||
(list (inset sc 0 0 (- 5 (pict-width sc)) 0)
|
|
||||||
(blank)
|
(blank)
|
||||||
;; In case sc set the max width...
|
;; n case this line sets the max width, add suitable space in the right:
|
||||||
(blank (max 0 (- (pict-width sc) max-lhs-w (pict-width =-pict) (* 2 sep)))
|
(blank (max 0 (- (pict-width p) max-lhs-w sep))
|
||||||
0)))))
|
0)))
|
||||||
lhss
|
null)
|
||||||
scs
|
(if (not sc)
|
||||||
rhss
|
null
|
||||||
linebreak-list))
|
(list (inset sc 0 0 (- 5 (pict-width sc)) 0)
|
||||||
ltl-superimpose ltl-superimpose
|
(blank)
|
||||||
sep sep)]
|
;; In case sc set the max width...
|
||||||
[(up-down)
|
(blank (max 0 (- (pict-width sc) max-lhs-w (pict-width =-pict) (* 2 sep)))
|
||||||
(apply vl-append
|
0)))))
|
||||||
sep
|
lhss
|
||||||
(apply append
|
scs
|
||||||
(map (lambda (lhs sc rhs)
|
rhss
|
||||||
(cons
|
linebreak-list))
|
||||||
(vl-append (hbl-append lhs =-pict) rhs)
|
ltl-superimpose ltl-superimpose
|
||||||
(if (not sc)
|
sep sep)]
|
||||||
null
|
[(up-down up-down/vertical-side-conditions)
|
||||||
(list (inset sc 0 0 (- 5 (pict-width sc)) 0)))))
|
(apply vl-append
|
||||||
lhss
|
sep
|
||||||
scs
|
(apply append
|
||||||
rhss)))])))))
|
(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?)
|
(define (metafunction-call name an-lw flattened?)
|
||||||
(if flattened?
|
(if flattened?
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user