added typesetting support for relations

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 

collects/redex/private/pict.rkt

@@ -1,18 +1,20 @@
-#lang scheme/base
+#lang racket/base
-(require (lib "mrpict.ss" "texpict")
+(require racket/contract
-         (lib "utils.ss" "texpict")
-         racket/contract
          racket/draw
-         scheme/class
+         racket/class
-         scheme/match
+         racket/match
-         (only-in scheme/list drop-right last partition)
+         (only-in racket/list drop-right last partition)
+         
+         texpict/mrpict
+         texpict/utils
+         
          "reduction-semantics.ss"
-         "struct.ss"
+         "struct.rkt"
-         "loc-wrapper.ss"
+         "loc-wrapper.rkt"
-         "matcher.ss"
+         "matcher.rkt"
-         "arrow.ss"
+         "arrow.rkt"
-         "core-layout.ss")
+         "core-layout.rkt")
-(require (for-syntax scheme/base))
+(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))))
 
 ;                              
 ;                              

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)
          

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

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)

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