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

added typesetting support for relations

Browse Source
This commit is contained in:
Robby Findler 2011-04-28 10:30:06 -05:00
parent d3d8659183
commit 8fbefb0b6d
7 changed files with 145 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/redex/pict.rkt
View File

@ -45,8 +45,11 @@
pict?)])])
; syntax
(provide metafunction->pict
(provide relation->pict
metafunction->pict
metafunctions->pict
render-relation
render-metafunction
render-metafunctions)
@ -68,7 +71,9 @@
[linebreaks (parameter/c (or/c false/c (listof boolean?)))]
[curly-quotes-for-strings (parameter/c boolean?)]
[white-bracket-sizing (parameter/c
(-> string? number? (values number? number? number? number?)))])
(-> string? number? (values number? number? number? number?)))]
[horizontal-bar-spacing (parameter/c exact-nonnegative-integer?)]
[relation-clauses-combine (parameter/c (-> (listof pict?) pict?))])
(provide/contract
[rule-pict-style

96
collects/redex/private/pict.rkt
View File

@ -1,18 +1,20 @@
#lang scheme/base
(require (lib "mrpict.ss" "texpict")
(lib "utils.ss" "texpict")
racket/contract
#lang racket/base
(require racket/contract
racket/draw
scheme/class
scheme/match
(only-in scheme/list drop-right last partition)
racket/class
racket/match
(only-in racket/list drop-right last partition)
texpict/mrpict
texpict/utils
"reduction-semantics.ss"
"struct.ss"
"loc-wrapper.ss"
"matcher.ss"
"arrow.ss"
"core-layout.ss")
(require (for-syntax scheme/base))
"struct.rkt"
"loc-wrapper.rkt"
"matcher.rkt"
"arrow.rkt"
"core-layout.rkt")
(require (for-syntax racket/base))
(provide render-term
term->pict
@ -25,8 +27,11 @@
render-reduction-relation
render-reduction-relation-rules
relation->pict
metafunction->pict
metafunctions->pict
render-relation
render-metafunction
render-metafunctions
@ -56,7 +61,10 @@
compact-vertical-min-width
extend-language-show-union
set-arrow-pict!
arrow->pict)
arrow->pict
horizontal-bar-spacing
relation-clauses-combine)
(provide/contract
[linebreaks (parameter/c (or/c #f (listof boolean?)))])
@ -718,6 +726,12 @@
(andmap identifier? (syntax->list #'(name2 ...))))
#'(metafunctions->pict/proc (list (metafunction name1) (metafunction name2) ...) 'metafunctions->pict)]))
(define-syntax (relation->pict stx)
(syntax-case stx ()
[(_ name1)
(identifier? #'name1)
#'(relation->pict/proc (metafunction name1) 'relation->pict)]))
(define-syntax (render-metafunctions stx)
(syntax-case stx ()
[(_ name1 name2 ...)
@ -738,6 +752,15 @@
(identifier? #'name)
#'(render-metafunction/proc (list (metafunction name)) file 'render-metafunction)]))
(define-syntax (render-relation stx)
(syntax-case stx ()
[(_ name)
(identifier? #'name)
#'(render-relation/proc (metafunction name) #f)]
[(_ name #:file filename)
(identifier? #'name)
#'(render-relation/proc (metafunction name) filename)]))
(define linebreaks (make-parameter #f))
(define metafunction-pict-style (make-parameter 'left-right))
@ -772,6 +795,9 @@
(cons (car l) (loop (cdr l)))])))
(define (metafunctions->pict/proc mfs name)
(for ([mf (in-list mfs)])
(when (metafunc-proc-relation? (metafunction-proc mf))
(error name "expected metafunction as argument, got a relation")))
(unless (andmap (λ (mf) (eq? (metafunc-proc-lang (metafunction-proc (car mfs)))
(metafunc-proc-lang (metafunction-proc mf))))
mfs)
@ -1018,7 +1044,47 @@
[else
(parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))])
(metafunctions->pict/proc mfs name))]))
(define (render-relation/proc mf filename)
(cond
[filename
(save-as-ps (λ () (relation->pict/proc mf 'render-reduction-relation))
filename)]
[else
(parameterize ([dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1))])
(relation->pict/proc mf 'render-reduction-relation))]))
(define (relation->pict/proc mf name)
(unless (metafunc-proc-relation? (metafunction-proc mf))
(error name "expected relation as argument, got a metafunction"))
(let* ([all-nts (language-nts (metafunc-proc-lang (metafunction-proc mf)))]
[wrapper->pict (lambda (lw) (lw->pict all-nts lw))]
[all-eqns (metafunc-proc-pict-info (metafunction-proc mf))]
[all-conclusions
(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)))]
[eqns (select-cases all-eqns)]
[conclusions (select-cases all-conclusions)]
[premisess (map (lambda (eqn) (map wrapper->pict (list-ref eqn 2))) eqns)])
((relation-clauses-combine)
(for/list ([conclusion (in-list conclusions)]
[premises (in-list premisess)])
(define top (apply hbl-append 20 premises))
(define line-w (max (pict-width top) (pict-width conclusion)))
(vc-append
(horizontal-bar-spacing)
top
(dc (λ (dc dx dy) (send dc draw-line dx dy (+ dx line-w) dy))
line-w 1)
conclusion)))))
(define horizontal-bar-spacing (make-parameter 4))
(define relation-clauses-combine (make-parameter (λ (l) (apply vc-append 20 l))))
;
;

17
collects/redex/private/reduction-semantics.rkt
View File

@ -1137,7 +1137,7 @@
(symbol->string (bind-name y))))))
(define-values (struct:metafunc-proc make-metafunc-proc metafunc-proc? metafunc-proc-ref metafunc-proc-set!)
(make-struct-type 'metafunc-proc #f 8 0 #f null (current-inspector) 0))
(make-struct-type 'metafunc-proc #f 9 0 #f null (current-inspector) 0))
(define metafunc-proc-pict-info (make-struct-field-accessor metafunc-proc-ref 1))
(define metafunc-proc-lang (make-struct-field-accessor metafunc-proc-ref 2))
(define metafunc-proc-multi-arg? (make-struct-field-accessor metafunc-proc-ref 3))
@ -1145,6 +1145,7 @@
(define metafunc-proc-in-dom? (make-struct-field-accessor metafunc-proc-ref 5))
(define metafunc-proc-dom-pat (make-struct-field-accessor metafunc-proc-ref 6))
(define metafunc-proc-cases (make-struct-field-accessor metafunc-proc-ref 7))
(define metafunc-proc-relation? (make-struct-field-accessor metafunc-proc-ref 8))
(define-struct metafunction (proc))
@ -1343,7 +1344,9 @@
[(name2 name-predicate) (generate-temporaries (syntax (name name)))]
;; See "!!" below for information on the `seq-' bindings:
[seq-of-rhs #'(rhs ...)]
[seq-of-rhs (if relation?
#'((raw-rhses ...) ...)
#'(rhs ...))]
[seq-of-lhs #'(lhs ...)]
[seq-of-tl-side-cond/binds #'((stuff ...) ...)]
[seq-of-lhs-for-lw #'(lhs-for-lw ...)])
@ -1385,7 +1388,11 @@
([generate-lws
(lambda (stx)
(with-syntax
([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))]
([(rhs/lw ...)
#,(if relation?
#'(... (map (λ (x) #`(list #,@(map to-lw/proc (syntax->list x))))
(syntax->list #'(... seq-of-rhs))))
#'(... (map to-lw/proc (syntax->list #'(... seq-of-rhs)))))]
[(((bind-id/lw . bind-pat/lw) ...) ...)
;; Also for pict, extract pattern bindings
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
@ -1445,7 +1452,8 @@
'name
(let ([name (lambda (x) (name-predicate x))]) name)
dsc
(append cases parent-cases)))
(append cases parent-cases)
#,relation?))
dsc
`(codom-side-conditions-rewritten ...)
'name
@ -2380,6 +2388,7 @@
metafunc-proc-in-dom?
metafunc-proc-dom-pat
metafunc-proc-cases
metafunc-proc-relation?
metafunc-proc?
(struct-out metafunc-case)

33
collects/redex/redex.scrbl
View File

@ -1933,6 +1933,7 @@ and for use in DrRacket to easily adjust the typesetting:
@racket[render-term],
@racket[render-language],
@racket[render-reduction-relation],
@racket[render-relation],
@racket[render-metafunctions], and
@racket[render-lw],
and one
@ -2067,6 +2068,27 @@ This function sets @racket[dc-for-text-size]. See also
and renders them together.
}
@deftogether[(@defform[(render-relation relation-name)]{}
@defform/none[#:literals (render-relation)
(render-relation relation-name filename)]{})]{
If provided with one argument, @racket[render-relation]
produces a pict that renders properly in the definitions
window in DrRacket. If given two arguments, it writes
postscript into the file named by @racket[filename] (which
may be either a string or bytes).
This function sets @racket[dc-for-text-size]. See also
@racket[relation->pict].
}
@defform[(relation->pict relation-name)]{
This produces a pict, but without setting @racket[dc-for-text-size].
It is suitable for use in Slideshow or other libraries that combine
picts.
}
@subsection{Customization}
@defparam[render-language-nts nts (or/c false/c (listof symbol?))]{
@ -2324,6 +2346,17 @@ single reduction relation.
}
@defparam[horizontal-bar-spacing space (parameter/c exact-nonnegative-integer?) 4]{
Controls the amount of space around the horizontal bar when rendering
a relation (that was created by @racket[define-relation]).
}
@defparam[relation-clauses-combine combine
(parameter/c (-> (listof pict?) pict?))
(λ (l) (apply vc-append 20 l))]{
@racket[combine] is called with the list of picts that are obtained by rendering
a relation; it should put them together into a single pict.
}
@section[#:tag "pink"]{Removing the pink background from PLT Redex rendered picts and ps files}
When reduction rules, a metafunction, or a grammar contains

9
collects/redex/tests/bitmap-test.rkt
View File

@ -243,5 +243,14 @@
hole))
(test (render-language L) "holes.png"))
(let ()
;; the 'has no lambdas' relation (useful because it has a case with no premises)
(define-relation lang
[(r e_1 e_2) (r e_1) (r e_2)]
[(r x)])
(test (render-relation r) "relation.png"))
(printf "bitmap-test.ss: ")
(done)

BIN
collects/redex/tests/bmps-macosx/relation.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.3 KiB

2
doc/release-notes/redex/HISTORY.txt
View File

@ -1,3 +1,5 @@
* added support for typsetting define-relation relations
v5.1.1
* changed pattern language to disallow unquote