diff --git a/quad/qtest/markdown.rkt b/quad/qtest/markdown.rkt index e4faeaaa..2fecc5a7 100644 --- a/quad/qtest/markdown.rkt +++ b/quad/qtest/markdown.rkt @@ -18,23 +18,23 @@ (define-tag-function (p attrs exprs) ;; no font-family so that it adopts whatever the surrounding family is - (qexpr (append `((keep-first "2")(keep-last "3") (hyphenate "true") (display ,(symbol->string (gensym)))) attrs) exprs)) + (qexpr (append `((keep-first "2")(keep-last "3")(font-size "12") (hyphenate "true") (display ,(symbol->string (gensym)))) attrs) exprs)) (define-tag-function (hr attrs exprs) hrbr) (define-tag-function (blockquote attrs exprs) - (qexpr (append '((display "block") - #;(line-align "center") - (background-color "#eee") - (font-family "fira") (font-size "10") (line-height "15") - (border-width-top "0.5") (border-color-top "gray") (border-inset-top "8") - (border-width-left "3") (border-color-left "gray") (border-inset-left "20") - (border-width-bottom "0.5") (border-color-bottom "gray") (border-inset-bottom "-2") - (border-width-right "0.5") (border-color-right "gray") (border-inset-right "20") - (inset-top "10") (inset-bottom "8") (inset-left "30") (inset-right "30") - (keep-lines "yes")) - attrs) exprs)) + (qexpr (append '((display "block") + (line-align "right") + (background-color "#eee") + (font-family "fira") (font-size "10") (line-height "15") + (border-width-top "0.5") (border-color-top "gray") (border-inset-top "8") + (border-width-left "3") (border-color-left "gray") (border-inset-left "20") + (border-width-bottom "0.5") (border-color-bottom "gray") (border-inset-bottom "-2") + (border-width-right "0.5") (border-color-right "gray") (border-inset-right "20") + (inset-top "10") (inset-bottom "8") (inset-left "30") (inset-right "30") + (keep-lines "yes")) + attrs) exprs)) (define id (default-tag-function 'id)) (define class (default-tag-function 'class)) @@ -133,20 +133,25 @@ (cond [(line-break? q) q] [else - (struct-copy - quad q:string - [attrs (let ([attrs (quad-attrs q)]) - (hash-ref! attrs 'font-size default-font-size) - attrs)] - [elems (quad-elems q)] - [size (delay - (font-size doc (quad-ref q 'font-size)) - (font doc (path->string (quad-ref q font-path-key default-font-face))) - (define str (if (pair? (quad-elems q)) (unsafe-car (quad-elems q)) "")) - (define line-height (cond - [(and (pair? (quad-elems q)) (quad-ref q 'line-height))] - [else (current-line-height doc)])) - (pt (string-width doc str) line-height))])])) + (let* ([q-elems (quad-elems q)] + [soft-hyphen? (equal? q-elems '("\u00AD"))]) + (struct-copy + quad q:string + [attrs (let ([attrs (quad-attrs q)]) + (hash-ref! attrs 'font-size default-font-size) + attrs)] + [elems q-elems] + [printable (if soft-hyphen? + (λ (q [sig #f]) (eq? sig 'end)) + (quad-printable q))] + [size (delay + (font-size doc (quad-ref q 'font-size)) + (font doc (path->string (quad-ref q font-path-key default-font-face))) + (define str (if (pair? q-elems) (unsafe-car q-elems) "")) + (define line-height (cond + [(and (pair? q-elems) (quad-ref q 'line-height))] + [else (current-line-height doc)])) + (pt (string-width doc str) line-height))]))])) (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"]) @@ -186,10 +191,10 @@ (and (pair? (quad-elems q)) (member (unsafe-car (quad-elems q)) softies))) -(define (consolidate-runs pcs) +(define (consolidate-runs pcs #:finalize [finalize-proc reverse]) (for/fold ([runs empty] [pcs pcs] - #:result (reverse runs)) + #:result (finalize-proc runs)) ([i (in-naturals)] #:break (empty? pcs)) (define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? (car pcs) p)))) @@ -236,15 +241,16 @@ (match (quad-ref q 'hyphenate #false) [(or #false "false") (list q)] [_ (for*/list ([str (in-list (quad-elems q))] - [hstr (in-value (hyphenate str + [hyphen-char (in-value #\u00AD)] + [hstr (in-value (hyphenate str hyphen-char #:min-left-length 4 - #:min-right-length 4 - #:min-hyphens 1))] - [substr (in-list (regexp-match* #rx"(-|\u00AD)" hstr #:gap-select? #t))]) + #:min-right-length 3))] + [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) (struct-copy quad q [elems (list substr)]))])))) (define (line-wrap qs wrap-size) - (wrap (handle-hyphenate qs) (λ (q idx) (- wrap-size (quad-ref q 'inset-left 0) (quad-ref q 'inset-right 0))) + (wrap qs + (λ (q idx) (- wrap-size (quad-ref q 'inset-left 0) (quad-ref q 'inset-right 0))) #:nicely #t #:hard-break line-break? #:soft-break soft-break-for-line? @@ -252,7 +258,11 @@ ;; so idx=1 means first line in any paragraph #:wrap-count (λ (idx q) (if (para-break? q) 1 (add1 idx))) #:finish-wrap - (λ (pcs opening-q ending-q idx) + (λ (pcs-in opening-q ending-q idx) + ;; remove unused soft hyphens so they don't affect final shaping + (define pcs (for/list ([pc (in-list pcs-in)] + #:unless (equal? (quad-elems pc) '("\u00AD"))) + pc)) (append (cond [(empty? pcs) null] @@ -267,7 +277,23 @@ (line-width doc 3) (stroke doc "#999"))]))] [else - (match (consolidate-runs pcs) + (match (consolidate-runs pcs + #:finalize (λ (reversed-runs) + (reverse (if (and ending-q (equal? (quad-elems ending-q) '("\u00AD"))) + ;; naive handling of soft hyphen: + ;; if soft hyphen cause the break, then append a printing hyphen to the end of the run. + ;; this assumes that there is room for the hyphen on the line + ;; and does not take into account hyphen-break transformations + ;; found in other languages. + ;; However we do want the hyphen joined into the string + ;; so the final shaping / positioning is correct + ;; for instance, kerning between last letter and hyphen. + ;; todo: this finagle doesn't update the `size` correctly + ;; so center & right alignment look wrong + (cons (let ([r (car reversed-runs)]) + (struct-copy quad r + [elems (list (string-append (car (quad-elems r)) "-"))])) (cdr reversed-runs)) + reversed-runs)))) [(? pair? elems) (define elem (unsafe-car elems)) (match-define (list line-width line-height) (quad-size q:line)) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index ec8d47f9..d759a9d8 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -180,6 +180,8 @@ (define last-line-can-be-short? #t) (define mega-penalty 1e8) +(define hyphen-penalty +inf.0) +(define max-consecutive-hyphens 1) (define (pieces-sublist pieces i j) (reverse (apply append (for/list ([n (in-range i j)]) (vector-ref pieces n))))) @@ -195,37 +197,45 @@ (wrap-pieces-best pieces-vec wrap-idx previous-wrap-ender wrap-count distance-func max-distance-proc finish-wrap)) (values (cons wraps wrapss) idx ender))) -(struct penalty-rec (val idx) #:transparent) +(struct penalty-rec (val idx hyphen-count) #:transparent) (define (wrap-pieces-best pieces-vec starting-wrap-idx previous-last-q wrap-count distance-func max-distance-proc finish-wrap) (define (penalty i j) (cond [(or (= i j) (> j (vector-length pieces-vec))) (define out-of-bounds-signal (- i)) - (penalty-rec out-of-bounds-signal #f)] + (penalty-rec out-of-bounds-signal #f 0)] [else - (match-define (penalty-rec last-val starting-idx) (ocm-min-value ocm i)) + (match-define (penalty-rec last-val starting-idx hyphen-count) (ocm-min-value ocm i)) (define would-be-wrap-qs (pieces-sublist pieces-vec i j)) ; `reverse` to track ordinary wrap logic (define wrap-distance (for/fold ([last-dist 0]) ([q (in-list would-be-wrap-qs)]) (distance-func q last-dist would-be-wrap-qs))) (define underflow (- (max-distance-proc (car would-be-wrap-qs) starting-idx) wrap-distance)) + (define new-consecutive-hyphen-count + (if (equal? (quad-elems (car would-be-wrap-qs)) '("\u00AD")) (add1 hyphen-count) 0)) (penalty-rec (+ last-val ; include penalty so far (* starting-idx mega-penalty) ; new line penalty + (if (> new-consecutive-hyphen-count max-consecutive-hyphens) + (* hyphen-penalty (- new-consecutive-hyphen-count max-consecutive-hyphens)) + 0) (cond [(negative? underflow) ;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity. (* mega-penalty (- underflow))] - [((if last-line-can-be-short? < <=) j (vector-length pieces-vec)) + [(let ([on-last-line? (= j (vector-length pieces-vec))]) + (or (not on-last-line?) + (and on-last-line? (not last-line-can-be-short?)))) ;; standard penalty (expt underflow 2)] [else 0])) - (wrap-count starting-idx (car would-be-wrap-qs)))])) + (wrap-count starting-idx (car would-be-wrap-qs)) + new-consecutive-hyphen-count)])) ;; starting from last position, ask ocm for position of row minimum (= new-pos) ;; collect this value, and use it as the input next time ;; until you reach first position. - (define ocm (make-ocm penalty (penalty-rec 0 starting-wrap-idx) penalty-rec-val)) + (define ocm (make-ocm penalty (penalty-rec 0 starting-wrap-idx 0) penalty-rec-val)) (define breakpoints (let ([last-j (vector-length pieces-vec)]) (let loop ([bps (list last-j)]) ; start from end