diff --git a/pkgs/redex-pkgs/redex-doc/redex/scribblings/ref.scrbl b/pkgs/redex-pkgs/redex-doc/redex/scribblings/ref.scrbl index 350c9356cc..03dbdc2db2 100644 --- a/pkgs/redex-pkgs/redex-doc/redex/scribblings/ref.scrbl +++ b/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. diff --git a/pkgs/redex-pkgs/redex-pict-lib/redex/pict.rkt b/pkgs/redex-pkgs/redex-pict-lib/redex/pict.rkt index 548b1ee99c..be85b227be 100644 --- a/pkgs/redex-pkgs/redex-pict-lib/redex/pict.rkt +++ b/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?))] diff --git a/pkgs/redex-pkgs/redex-pict-lib/redex/private/core-layout.rkt b/pkgs/redex-pkgs/redex-pict-lib/redex/private/core-layout.rkt index 8f312ded25..729cd90026 100644 --- a/pkgs/redex-pkgs/redex-pict-lib/redex/private/core-layout.rkt +++ b/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 "⎨") diff --git a/pkgs/redex-pkgs/redex-test/redex/tests/bitmap-test.rkt b/pkgs/redex-pkgs/redex-test/redex/tests/bitmap-test.rkt index 7a5a0d84b7..d5e68b5b55 100644 --- a/pkgs/redex-pkgs/redex-test/redex/tests/bitmap-test.rkt +++ b/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,