change the whitebracket abstractions in redex

and introduce a horrible hack to deal with what
appears to be far too much whitespace on the sides
of the whitebracket characters

pkgs/redex-pkgs/redex-doc/redex/scribblings/ref.scrbl

@@ -3217,16 +3217,40 @@ precede ellipses that represent argument sequences; when it is
 @racket[#f] no commas appear in those positions.
 }
 
-@defparam[use-homemade-white-brackets homemade? boolean?]{
+@defparam[white-square-bracket make-white-square-bracket (-> boolean? pict?)]{
 This parameter controls the typesetting of the brackets in metafunction
-definitions and applications. When it is @racket[#f] (the default),
-Redex uses the unicode characters @litchar{〚} and  @litchar{〛}
-around the parameters. Otherwise, it uses two overlapping
-@litchar{[} and  @litchar{]} chars with a little whitespace between them.
+definitions and applications. It is called to supply the two white bracket
+picts. If @racket[#t] is supplied, the function should return the open 
+white bracket (to be used at the left-hand side of an application) and if
+@racket[#f] is supplied, the function should return the close white bracket.
+
+It's default value is @racket[default-white-square-bracket]. See also
+@racket[homemade-white-square-bracket].
 
 @history[#:added "1.1"]
 }
 
+@defproc[(homemade-white-square-bracket [open? boolean?]) pict?]{
+ This function implements the default way that older versions
+ of Redex typeset whitebrackets. It uses two overlapping
+ @litchar{[} and  @litchar{]} chars with a little whitespace between them.
+
+ @history[#:added "1.1"]
+}
+
+@defproc[(default-white-square-bracket [open? boolean?]) pict?]{
+ This function returns picts built using
+ @litchar{〚} and  @litchar{〛}
+ in the style @racket[default-style], using
+ @racket[current-text] and @racket[default-font-size].
+
+ If these result in picts that are more than 1/2 whitespace,
+ then 1/3 of the whitespace is trimmed from sides (trimmed
+ only from the left of the open and the right of the close).
+ 
+ @history[#:added "1.1"]
+}
+
 @defparam[linebreaks breaks (or/c #f (listof boolean?))]{
   This parameter controls which cases in the metafunction 
   are rendered on two lines and which are rendered on one.

pkgs/redex-pkgs/redex-pict-lib/redex/pict.rkt

@@ -101,7 +101,10 @@
                         'up-down/vertical-side-conditions
                         'up-down/compact-side-conditions))]
  [delimit-ellipsis-arguments? (parameter/c any/c)]
- [use-homemade-white-brackets (parameter/c boolean?)])
+ 
+ [default-white-square-bracket (-> boolean? pict?)]
+ [homemade-white-square-bracket (-> boolean? pict?)]
+ [white-square-bracket (parameter/c (-> boolean? pict?))])
 
 (provide/contract
  [label-font-size (parameter/c (and/c (between/c 1 255) integer?))]

pkgs/redex-pkgs/redex-pict-lib/redex/private/core-layout.rkt

@@ -37,8 +37,13 @@
          literal-style
          metafunction-style
          delimit-ellipsis-arguments?
+         
          open-white-square-bracket
          close-white-square-bracket
+         default-white-square-bracket
+         homemade-white-square-bracket
+         white-square-bracket
+         
          just-before
          just-after
          with-unquote-rewriter
@@ -784,16 +789,56 @@
   (define metafunction-font-size (make-parameter (default-font-size)))
   (define label-font-size (make-parameter 14))
   (define delimit-ellipsis-arguments? (make-parameter #t))
-  
+
+(define white-square-bracket-cache (make-hash))
+(define (default-white-square-bracket open?)
+  (define key (list (current-text) (default-style) (default-font-size) open?))
+  (cond
+    [(hash-ref white-square-bracket-cache key #f) => values]
+    [else
+     (define candidate ((current-text) (if open? "〚" "〛") (default-style) (default-font-size)))
+     (define w (inexact->exact (ceiling (pict-width candidate))))
+     (define h (inexact->exact (ceiling (pict-height candidate))))
+     (define bmp (make-bitmap w h))
+     (define bdc (make-object bitmap-dc% bmp))
+     (draw-pict candidate bdc 0 0)
+     (define bytes (make-bytes (* w h 4)))
+     (send bmp get-argb-pixels 0 0 w h bytes)
+     (define (white-pixel? x y)
+       (define c (* 4 (+ (* y w) x)))
+       (= (bytes-ref bytes c) 0))
+     (define outermost-x
+       (let/ec k
+         (for ([x (if open?
+                      (in-range w)
+                      (in-range (- w 1) -1 -1))])
+           (define the-y
+             (for/or ([y (in-range h)])
+               (and (not (white-pixel? x y))
+                    y)))
+           (when the-y
+             (k x)))))
+     (define pict
+       (cond 
+         [(if open?
+              (<= 1/2 (/ outermost-x w))
+              (<= 1/2 (/ (- w outermost-x) w)))
+          ;; when the entire half is white
+          (if open?
+              (inset/clip candidate (- (/ w 3)) 0 0 0)
+              (inset/clip candidate 0 0 (- (/ w 3)) 0))]
+         [else
+          candidate]))
+     (hash-set! white-square-bracket-cache key pict)
+     pict]))
+
+(define (homemade-white-square-bracket open?)
+  (white-bracket (if open? "[" "]")))
+
+(define white-square-bracket (make-parameter default-white-square-bracket))
 (define use-homemade-white-brackets (make-parameter #f))
-(define (open-white-square-bracket) 
-  (if (use-homemade-white-brackets)
-      (white-bracket "[")
-      (basic-text "〚" (default-style))))
-(define (close-white-square-bracket)
-  (if (use-homemade-white-brackets)
-      (white-bracket "]")
-      (basic-text "〛" (default-style))))
+(define (open-white-square-bracket) ((white-square-bracket) #t))
+(define (close-white-square-bracket) ((white-square-bracket) #f))
 
 (define left-curly-bracket-upper-hook "⎧")
 (define left-curly-bracket-middle-piece "⎨")

pkgs/redex-pkgs/redex-test/redex/tests/bitmap-test.rkt

@@ -4,7 +4,7 @@
          pict)
 
 (module test racket/base) ; run by run-tests
-(use-homemade-white-brackets #t)
+(white-square-bracket homemade-white-square-bracket)
 
 ;; tests: 
 ;;  - language,