diff --git a/collects/redex/pict.rkt b/collects/redex/pict.rkt index 04ce663440..340096693c 100644 --- a/collects/redex/pict.rkt +++ b/collects/redex/pict.rkt @@ -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 diff --git a/collects/redex/private/pict.rkt b/collects/redex/private/pict.rkt index 2e1c563091..1020c95daf 100644 --- a/collects/redex/private/pict.rkt +++ b/collects/redex/private/pict.rkt @@ -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)))) ; ; diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 8bcc01915e..746a5f4604 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -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) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 54d0ace93c..752a19712d 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -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 diff --git a/collects/redex/tests/bitmap-test.rkt b/collects/redex/tests/bitmap-test.rkt index a0855d0882..3cfd2663bc 100644 --- a/collects/redex/tests/bitmap-test.rkt +++ b/collects/redex/tests/bitmap-test.rkt @@ -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) diff --git a/collects/redex/tests/bmps-macosx/relation.png b/collects/redex/tests/bmps-macosx/relation.png new file mode 100644 index 0000000000..5ad5b6abfa Binary files /dev/null and b/collects/redex/tests/bmps-macosx/relation.png differ diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 1ff0e43d84..3f023c7acb 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,5 @@ + * added support for typsetting define-relation relations + v5.1.1 * changed pattern language to disallow unquote