PR 10042

svn: r13444

collects/redex/pict.ss

@@ -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?))]

collects/redex/private/bitmap-test.ss

@@ -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)

collects/redex/private/pict.ss

@@ -651,10 +651,11 @@
 
 (define metafunction->pict/proc
   (lambda (mf)
-    (let ([current-linebreaks (linebreaks)]
+    (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))]
+           [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
@@ -672,7 +673,10 @@
                                                        (cons (wrapper->pict (car p))
                                                              (wrapper->pict (cdr p))))
                                                      (list-ref eqn 2))
-                                                  +inf.0)))
+                                                (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
@@ -690,8 +694,8 @@
                                     (+ (pict-width lhs) (pict-width rhs) (pict-width =-pict)
                                        (* 2 sep)))))
                              lhss scs rhss linebreak-list))])
-        (case (metafunction-pict-style)
-          [(left-right)
+      (case style
+        [(left-right left-right/vertical-side-conditions)
          (table 3
                 (apply append
                        (map (lambda (lhs sc rhs linebreak?)
@@ -722,7 +726,7 @@
                             linebreak-list))
                 ltl-superimpose ltl-superimpose
                 sep sep)]
-          [(up-down)
+        [(up-down up-down/vertical-side-conditions)
          (apply vl-append
                 sep
                 (apply append
@@ -734,7 +738,7 @@
                                    (list (inset sc 0 0 (- 5 (pict-width sc)) 0)))))
                             lhss
                             scs
-                              rhss)))])))))
+                            rhss)))]))))
 
 (define (metafunction-call name an-lw flattened?)
   (if flattened?

collects/redex/redex.scrbl

@@ -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