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)]
|
||||
[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?))]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
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
|
||||
(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?
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user