added the ability to render multiple metafunctions together to make all the lhss line up in a single column
svn: r13459
This commit is contained in:
Robby Findler
parent
facfa48e80
commit
4de2439506
|
|
@ -42,7 +42,9 @@
|
|||
|
||||
; syntax
|
||||
(provide metafunction->pict
|
||||
render-metafunction)
|
||||
metafunctions->pict
|
||||
render-metafunction
|
||||
render-metafunctions)
|
||||
|
||||
(provide/contract
|
||||
[render-language-nts (parameter/c (or/c false/c (listof (or/c string? symbol?))))]
|
||||
|
|
|
|||
|
|
@ -139,5 +139,9 @@
|
|||
(render-metafunction subst))
|
||||
"metafunction-subst.png")
|
||||
|
||||
|
||||
;; make sure two metafunctions simultaneously rewritten line up properly
|
||||
(test (render-metafunctions S T TL) "metafunctions-multiple.png")
|
||||
|
||||
(printf "bitmap-test.ss: ")
|
||||
(done)
|
||||
|
|
|
|||
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB After Width: | Height: | Size: 4.6 KiB |
BIN
collects/redex/private/bmps/metafunctions-multiple.png
Normal file
BIN
collects/redex/private/bmps/metafunctions-multiple.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 7.8 KiB |
|
|
@ -20,7 +20,9 @@
|
|||
render-reduction-relation-rules
|
||||
|
||||
metafunction->pict
|
||||
metafunctions->pict
|
||||
render-metafunction
|
||||
render-metafunctions
|
||||
|
||||
basic-text
|
||||
|
||||
|
|
@ -634,111 +636,136 @@
|
|||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(identifier? #'name)
|
||||
#'(metafunction->pict/proc (metafunction name))]))
|
||||
#'(metafunctions->pict name)]))
|
||||
|
||||
(define-syntax (metafunctions->pict stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name1 name2 ...)
|
||||
(and (identifier? #'name1)
|
||||
(andmap identifier? (syntax->list #'(name2 ...))))
|
||||
#'(metafunctions->pict/proc (list (metafunction name1) (metafunction name2) ...) 'metafunctions->pict)]))
|
||||
|
||||
(define-syntax (render-metafunctions stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name1 name2 ...)
|
||||
(and (identifier? #'name)
|
||||
(andmap identifier? (syntax->list #'(name2 ...))))
|
||||
#'(render-metafunction/proc (list (metafunction name1) (metafunction name2) ...) #f 'render-metafunctions)]
|
||||
[(_ name1 name2 ... #:file filename)
|
||||
(and (identifier? #'name1)
|
||||
(andmap identifier? (syntax->list #'(name2 ...))))
|
||||
#'(render-metafunction/proc (list (metafunction name1) (metafunction name2) ...) file 'render-metafunctions)]))
|
||||
|
||||
(define-syntax (render-metafunction stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(identifier? #'name)
|
||||
#'(render-metafunction/proc (metafunction name))]
|
||||
#'(render-metafunction/proc (list (metafunction name)) #f 'render-metafunction)]
|
||||
[(_ name file)
|
||||
(identifier? #'name)
|
||||
#'(render-metafunction/proc (metafunction name) file)]))
|
||||
#'(render-metafunction/proc (list (metafunction name)) file 'render-metafunction)]))
|
||||
|
||||
(define linebreaks (make-parameter #f))
|
||||
|
||||
(define metafunction-pict-style (make-parameter 'left-right))
|
||||
|
||||
(define metafunction->pict/proc
|
||||
(lambda (mf)
|
||||
(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)
|
||||
;; 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)
|
||||
(define (metafunctions->pict/proc mfs name)
|
||||
(unless (andmap (λ (mf) (eq? (metafunc-proc-lang (metafunction-proc (car mfs)))
|
||||
(metafunc-proc-lang (metafunction-proc mf))))
|
||||
mfs)
|
||||
(error name "expected metafunctions that are all drawn from the same language"))
|
||||
(let* ([current-linebreaks (linebreaks)]
|
||||
[all-nts (language-nts (metafunc-proc-lang (metafunction-proc (car mfs))))]
|
||||
[sep 2]
|
||||
[style (metafunction-pict-style)]
|
||||
[wrapper->pict (lambda (lw) (lw->pict all-nts lw))]
|
||||
[eqns (apply append (map (λ (mf) (metafunc-proc-pict-info (metafunction-proc mf))) mfs))]
|
||||
[lhss
|
||||
(apply append
|
||||
(map (λ (mf)
|
||||
(map (lambda (eqn)
|
||||
(wrapper->pict
|
||||
(metafunction-call (metafunc-proc-name (metafunction-proc mf))
|
||||
(list-ref eqn 0)
|
||||
(metafunc-proc-multi-arg? (metafunction-proc mf)))))
|
||||
(metafunc-proc-pict-info (metafunction-proc mf))))
|
||||
mfs))]
|
||||
[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 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)))]))))
|
||||
;; 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?
|
||||
|
|
@ -848,12 +875,12 @@
|
|||
(basic-text "]" (default-style)))])]
|
||||
[else x]))
|
||||
|
||||
(define render-metafunction/proc
|
||||
(case-lambda
|
||||
[(mf filename)
|
||||
(save-as-ps (λ () (metafunction->pict/proc mf))
|
||||
(define (render-metafunction/proc mfs filename name)
|
||||
(cond
|
||||
[filename
|
||||
(save-as-ps (λ () (metafunctions->pict/proc mfs name))
|
||||
filename)]
|
||||
[(mf)
|
||||
[else
|
||||
(parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))])
|
||||
(metafunction->pict/proc mf))]))
|
||||
(metafunctions->pict/proc mfs name))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -1474,7 +1474,7 @@ 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],
|
||||
@scheme[render-metafunction], and
|
||||
@scheme[render-metafunctions], and
|
||||
@scheme[render-lw],
|
||||
and one
|
||||
for use in combination with other libraries that operate on picts
|
||||
|
|
@ -1549,16 +1549,24 @@ other tools that combine picts together.
|
|||
@deftogether[[
|
||||
@defform[(render-metafunction metafunction-name)]{}
|
||||
@defform/none[#:literals (render-metafunction)
|
||||
(render-metafunction metafunction-name filename)]{}]]{
|
||||
(render-metafunction metafunction-name filename)]{}
|
||||
@defform[(render-metafunctions metafunction-name ...)]{}
|
||||
@defform/none[#:literals (render-metafunction)
|
||||
(render-metafunctions metafunction-name ... #:file filename)]{}]]{
|
||||
|
||||
If provided with one argument, @scheme[render-metafunction]
|
||||
produces a pict that renders properly in the definitions
|
||||
window in DrScheme. If given two argument, it writes
|
||||
window in DrScheme. If given two arguments, it writes
|
||||
postscript into the file named by @scheme[filename] (which
|
||||
may be either a string or bytes).
|
||||
|
||||
Similarly, @scheme[render-metafunctions] accepts multiple
|
||||
metafunctions and renders them together, lining up all of the
|
||||
clauses together.
|
||||
|
||||
This function sets @scheme[dc-for-text-size]. See also
|
||||
@scheme[metafunction->pict].
|
||||
@scheme[metafunction->pict] and
|
||||
@scheme[metafunctions->pict].
|
||||
}
|
||||
|
||||
@defform[(metafunction->pict metafunction-name)]{
|
||||
|
|
@ -1567,6 +1575,15 @@ This function sets @scheme[dc-for-text-size]. See also
|
|||
picts.
|
||||
}
|
||||
|
||||
@defform[(metafunctions->pict metafunction-name ...)]{
|
||||
Like @scheme[metafunction->pict],
|
||||
this produces a pict, but without setting @scheme[dc-for-text-size]
|
||||
and is suitable for use in Slideshow or other libraries that combine
|
||||
picts. Like
|
||||
@scheme[render-metafunctions], it accepts multiple metafunctions
|
||||
and renders them together.
|
||||
}
|
||||
|
||||
@subsection{Customization}
|
||||
|
||||
@defparam[render-language-nts nts (or/c false/c (listof symbol?))]{
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user