You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/quad/quadwriter/line.rkt

313 lines
16 KiB
Racket

#lang debug racket
(require quad/quad
"struct.rkt"
"param.rkt"
"debug.rkt"
"font.rkt"
"string.rkt"
"attrs.rkt"
5 years ago
quad/base
sugar/list
pitfall
racket/unsafe/ops)
(provide (all-defined-out))
(define (hr-draw dq doc)
(match-define (list left top) (quad-origin dq))
(match-define (list right bottom) (size dq))
(save doc)
(translate doc left (+ top (/ bottom 2.0)))
(move-to doc 0 0)
(line-to doc right 0)
(line-width doc 0.5)
(stroke doc "black")
(restore doc))
(define (make-hr-quad line-q)
(quad-copy line-quad line-q [draw-start hr-draw]))
(define q:line (make-quad
#:type line-quad
#:size (pt 0 default-line-height)
#:from 'sw
#:to 'nw
#:printable #true
5 years ago
#:tag 'line
#:draw-start (if draw-debug-line? draw-debug void)))
(define (render-hyphen qs ending-q)
;; 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.
(match (and ending-q (equal? (quad-elems ending-q) '("\u00AD")) qs)
[(list head ... last-q)
(define str (car (quad-elems last-q)))
(define str+hyphen (string-append str "-"))
(append head
(list (quad-update! last-q
[elems (list str+hyphen)]
[size (make-size-promise-for-string last-q str+hyphen)])))]
[_ qs]))
(define (space-quad? q) (equal? (quad-elems q) (list " ")))
(define (hang-punctuation nonspacess)
(match nonspacess
[(list sublists ... (list prev-qs ... last-q))
#:when (pair? (quad-elems last-q))
(match (regexp-match #rx"[.,:;-]$" (car (quad-elems last-q)))
[#false nonspacess]
[last-char-str
(define hanger-q (quad-copy string-quad last-q
[elems null]
[size (let ([p (make-size-promise-for-string last-q (car last-char-str))])
(delay
(match-define (list x y) (force p))
(pt (- x) y)))]))
(define last-sublist (append prev-qs (list last-q hanger-q)))
(append sublists (list last-sublist))])]
[_ nonspacess]))
(define (sum-sum-x qss)
(for/sum ([qs (in-list qss)])
(sum-x qs)))
(define (tracking-adjustment q)
(match q
[(? string-quad?) (/ (quad-ref q :font-tracking 0) 2.0)]
[_ 0]))
(define (fill-line-wrap all-qs line-prototype last-line-in-paragraph?)
;; happens during the finish of a line wrap, before consolidation of runs
(unless (pair? all-qs)
(raise-argument-error 'fill-line-wrap "nonempty list of quads" all-qs))
5 years ago
;; remove anchored quads because they don't affect line layout
(define-values (absolute-qs qs) (partition (λ (q) (quad-ref q :anchor-parent)) all-qs))
5 years ago
(match qs
[(? null?) absolute-qs]
[(and (cons q-first other-qs) (list _ ... q-last))
(define align-value (quad-ref q-first :line-align "left"))
;; words may still be in hyphenated fragments
;; (though soft hyphens would have been removed)
;; so group them (but no need to consolidate — that happens elsewhere)
(define-values (spacess nonspacess) (partition* space-quad? qs))
(match (length nonspacess)
[1 #:when (equal? align-value "justify") qs] ; can't justify single word
[nonspacess-count
(match-define (list line-prototype-width line-prototype-height) (quad-size line-prototype))
(define hung-nonspacess (hang-punctuation nonspacess))
(define left-tracking-adjustment (tracking-adjustment q-first))
(define right-tracking-adjustment (tracking-adjustment q-last))
(define nonspace-total-width
(- (sum-sum-x hung-nonspacess) left-tracking-adjustment right-tracking-adjustment))
(define space-total-width (sum-sum-x spacess))
(define empty-hspace (- line-prototype-width
(quad-ref q-first :inset-left 0)
nonspace-total-width
(quad-ref q-first :inset-right 0)))
5 years ago
(define (make-left-edge-filler [width 0])
(make-quad #:type filler-quad
#:tag 'line-filler
#:from-parent (quad-from-parent q-first)
#:from 'bo
#:to 'bi
#:shift (pt (- left-tracking-adjustment) 0)
#:size (pt width 0)
#:attrs (quad-attrs q-first)))
5 years ago
(cond
[(or
(and (equal? align-value "justify") (or (not last-line-in-paragraph?)
;; don't justify the last line in a paragraph
;; unless empty space is less than 17% of width (an arbitrary visual threshold)
(< (/ empty-hspace line-prototype-width 1.0) .17)))
(let ([line-overfull? (negative? (- empty-hspace space-total-width))])
;; force justification upon overfull lines,
;; which amounts to shrinking the word spaces till the line fits
(and line-overfull? (> nonspacess-count 1))))
(define justified-space-width (/ empty-hspace (sub1 nonspacess-count)))
(cons (make-left-edge-filler)
(apply append (add-between hung-nonspacess (list (make-quad
#:from 'bo
#:to 'bi
#:draw-end q:string-draw-end
#:size (pt justified-space-width line-prototype-height))))))]
[else
(define space-multiplier (match align-value
["center" 0.5]
;; fill inner & outer as if they were right,
;; they will be corrected later, when pagination is known.
[(or "right" "inner" "outer") 1]
;; "left" and "justify" are handled here
[_ 0]))
;; subtact space-width because that appears between words
;; we only care about redistributing the space on the ends
(define end-hspace (- empty-hspace space-total-width))
;; make filler a leading quad, not a parent / grouping quad,
;; so that elements can still be reached by consolidate-runs
(list* (make-left-edge-filler (* end-hspace space-multiplier))
(quad-update! q-first [from-parent #f])
;; ok to put back absolute quads at end, because it doesn't affect their layout
(append other-qs absolute-qs))])])]))
5 years ago
(define (make-paragraph-spacer maybe-first-line-q key default-val)
(define arbitrary-width 20)
(make-quad #:type line-spacer-quad
#:size (pt arbitrary-width (cond
[(and maybe-first-line-q (quad-ref maybe-first-line-q key))]
[else default-val]))
#:from 'sw
#:to 'nw
#:printable only-prints-in-middle
#:draw-start (if (draw-debug-line?) draw-debug void)))
5 years ago
(define ((line-wrap-finish line-prototype-q default-block-id) wrap-qs q-before q-after idx)
;; we curry line-q so that the wrap size can be communicated to this operation
;; remove unused soft hyphens so they don't affect final shaping
(define wrap-qs-printing (for/list ([wq (in-list wrap-qs)]
#:unless (equal? (quad-elems wq) '("\u00AD")))
wq))
(define new-lines
(cond
[(empty? wrap-qs-printing) null]
[(hr-break-quad? q-after) (list (make-hr-quad line-prototype-q))]
[else
;; render hyphen first so that all printable characters are available for size-dependent ops.
(define pcs-with-hyphen (render-hyphen wrap-qs-printing q-after))
;; fill wrap so that consolidate-runs works properly
;; (justified lines won't be totally consolidated)
(define last-line-in-paragraph? (not q-after))
(define pcs (fill-line-wrap pcs-with-hyphen line-prototype-q last-line-in-paragraph?))
(match (consolidate-runs pcs)
[(and (cons elem-first _) elems)
(match-define (list line-width line-height) (quad-size line-prototype-q))
(list
(quad-copy line-quad line-prototype-q
;; move block attrs up, so they are visible in col wrap
[attrs (let ([h (copy-block-attrs (quad-attrs elem-first) (hash-copy (quad-attrs line-prototype-q)))])
;; we want every group of lines in a paragraph to have a block id
;; so that it will be wrapped as a block later.
;; we only set this if there is no value for :display.
(hash-ref! h :display default-block-id)
h)]
;; line width is static
;; line height is the max 'line-height value or the natural height of q:line
[size (pt line-width (match (filter-map (λ (q) (or (quad-ref q :line-height) (pt-y (size q)))) pcs)
[(? null?) line-height]
[line-heights (apply max line-heights)]))]
;; handle list indexes. drop new quad into line to hold list index
;; could also use this for line numbers
[elems
;; we assume here that a list item has already had extra inset-left
;; with room for a bullet
;; which we just insert at the front.
;; this is safe because line has already been filled.
(append
;; only put bullet into line if we're at the first line of the list item
(match (and (eq? idx 1) (quad-ref elem-first :list-index))
[#false null]
[bullet
(define bq (quad-copy string-quad q:string ;; copy q:string to get draw routine
;; borrow attrs from elem
[attrs (quad-attrs elem-first)]
;; use bullet as elems
[elems (list (if (number? bullet) (format "~a." bullet) bullet))]
;; size doesn't matter because nothing refers to this quad
;; just for debugging box
[size (pt 15 (pt-y (size line-prototype-q)))]))
(from-parent (list bq) 'sw)])
(from-parent
(match (quad-ref elem-first :inset-left 0)
[0 elems]
[inset-val (cons (make-quad
#:draw-end q:string-draw-end
#:to 'sw
#:size (pt inset-val 5)
#:type offsetter-quad)
elems)]) 'sw))]))]
[_ null])]))
(define maybe-first-line (and (pair? new-lines) (car new-lines)))
(append (match q-before
[#false (list (make-paragraph-spacer maybe-first-line :space-before 0))] ; paragraph break
[_ null])
new-lines
(match q-after
[(? column-break-quad? column-break) (list column-break)] ; hard column (or section or page) break
[#false (list (make-paragraph-spacer maybe-first-line :space-after (* default-line-height 0.6)))] ; paragraph break
[_ null]))) ; hard line break
5 years ago
(define softies (map string '(#\space #\- #\u00AD)))
5 years ago
(define (soft-break-for-line? q)
(and (pair? (quad-elems q))
(member (unsafe-car (quad-elems q)) softies)))
5 years ago
(define (line-wrap qs wrap-size [debug #false])
(unless (positive? wrap-size)
(raise-argument-error 'line-wrap "positive number" wrap-size))
(match qs
[(cons q _)
(define line-q (quad-copy line-quad q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))]))
(define permitted-justify-overfill
(match (quad-ref q :line-align)
;; allow justified lines to go wider,
;; and then fill-wrap will tighten thes word spaces
;; this makes justified paragraphs more even, becuase
;; some lines are a little tight, as opposed to all of them being loose
["justify" 1.04]
[_ 1]))
;; group lines into sublists separated by para-breaks, but then omit the para-breaks themselves
;; because they've served their purpose (leave the others, to be expressed later)
;; however, leave line-breaks in, because they will be handled by wrap.
(define para-qss (let loop ([qs qs][acc null])
(match qs
[(? null?) (reverse acc)]
[(cons (? para-break-quad?) rest)
(loop rest acc)]
[(cons (? column-break-quad? bq) rest)
(loop rest (cons bq acc))]
[(list* (and (not (? para-break-quad?)) nbqs) ... rest)
(loop rest (cons nbqs acc))])))
(define res
(apply append
(for/list ([para-qs (in-list para-qss)])
(define block-id (gensym))
(match para-qs
[(? break-quad? bq) (list bq)]
[(cons pq _)
(wrap para-qs
(* (- wrap-size
(quad-ref pq :inset-left 0)
(quad-ref pq :inset-right 0))
permitted-justify-overfill)
debug
5 years ago
5 years ago
;; during wrap, anchored qs are treated as having distance 0
;; so they can staty in right place, so that relative queries will work.
;; but they won't affect where lines break
#:distance (λ (q last-dist wrap-qs)
(+ last-dist (cond
[(quad-ref q :anchor-parent) 0]
[(printable? q) (distance q)]
[else 0])))
#:nicely (match (or (current-line-wrap) (quad-ref pq :line-wrap))
[(or "best" "kp") #true]
[_ #false])
#:hard-break line-break-quad?
#:soft-break soft-break-for-line?
#:finish-wrap (line-wrap-finish line-q block-id))]))))
res]
[_ null]))
5 years ago