methodize text

main
Matthew Butterick 6 years ago
parent a46889001a
commit faa9f4327f

@ -24,254 +24,220 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/mixins/text.coffee
(super-new)
(field [_line-gap #f]
[_textOptions #f])
(define/public (init-text)
(set-field! x this 0)
(set-field! y this 0)
(line-gap 0)
(void))
(as-methods
init-text
init-options
line-gap
move-down
move-up
_text
_fragment
text
string-width)))
(define/public (line-gap _line-gap)
(set-field! _line-gap this _line-gap)
this)
(define/contract (init-text this)
(->m void?)
(set-field! x this 0)
(set-field! y this 0)
(line-gap this 0)
(void))
(define/public (move-down [lines 1] #:factor [factor 1])
(increment-field! y this (* factor (send this current-line-height #t) (+ lines (· this _line-gap))))
this)
(define/public (move-up [lines 1])
(move-down this #:factor -1))
(define/contract (line-gap this _line-gap)
(number? . ->m . object?)
(set-field! _line-gap this _line-gap)
this)
(define/contract (move-down this [lines 1] #:factor [factor 1])
(() (number? #:factor number?) . ->*m . object?)
(increment-field! y this (* factor (send this current-line-height #t) (+ lines (· this _line-gap))))
this)
(define/contract (move-up this [lines 1])
(() (number?) . ->*m . object?)
(move-down this #:factor -1))
(define/contract (_text this text x y options lineCallback)
(string? (or/c number? #f) (or/c number? #f) hash? procedure? . ->m . object?)
(let* ([options (send this init-options options x y)]
[text (format "~a" text)] ;; Convert text to a string
;; if the wordSpacing option is specified, remove multiple consecutive spaces
[text (if (hash-ref options 'wordSpacing #f)
(string-replace text #px"\\s{2,}" " ")
text)])
;; word wrapping
(cond
#;[(· options width)
(error 'unimplemented-branch-of-_text)] ; todo
[else ; render paragraphs as single lines
(for ([line (in-list (string-split text "\n"))])
(lineCallback line options))]))
this)
(define (text this text-string [x #f] [y #f] [options (mhash)])
(send this _text text-string x y options (λ args (apply _line this args))))
(define/contract (string-width this str [options (mhash)])
((string?) (hash?) . ->*m . number?)
#;(report str 'measuring-width-of)
(+ (send (· this current-font) string-width str (· this current-font-size) (hash-ref options 'features #f))
(* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))
(define/contract (init-options this [options (mhash)] [x #f] [y #f])
(() (hash? (or/c number? #f) (or/c number? #f)) . ->*m . hash?)
;; clone options object
(let ([options (hash-copy options)])
;; extend options with previous values for continued text
(when (· this _textOptions)
(for ([(key val) (in-hash (· this _textOptions))]
#:unless (equal? (key "continued")))
(hash-ref! options key val)))
;; Update the current position
(when x (set-field! x this x))
(when y (set-field! y this y))
;; wrap to margins if no x or y position passed
(unless (not (hash-ref options 'lineBreak #t))
(define margins (· this page margins))
(hash-ref! options 'width (λ () (- (· this page width) (· this x) (margin-right margins)))))
(hash-ref! options 'columns 0)
(hash-ref! options 'columnGap 18) ; 1/4 inch in PS points
options))
(define/public (_text text x y options lineCallback)
(define/contract (_line this text [options (mhash)] [wrapper #f])
((string?) (hash? (or/c procedure? #f)) . ->*m . void?)
(send this _fragment text (· this x) (· this y) options)
(define line-gap (or (· options line-gap) (· this _line-gap) 0))
;; 180325 suppress the size tracking: we'll do our own line measurement
;; 181120 unsuppress the size tracking for now because it breaks test 04
(if (not wrapper)
(increment-field! x this (send this string-width text))
(increment-field! y (+ (send this current-line-height #t) line-gap)))
(void))
(define/contract (_fragment this text x y-in options)
(string? number? number? hash? . ->m . void?)
(define align (hash-ref options 'align 'left))
(define wordSpacing (hash-ref options 'wordSpacing 0))
(define characterSpacing (hash-ref options 'characterSpacing 0))
;; text alignments ; todo
;; calculate the actual rendered width of the string after word and character spacing
(define renderedWidth
;; wrap this in delay so it's only calculated if needed
(delay
(+ (or (· options textWidth) (string-width this text options))
(* wordSpacing (sub1 (or (· options wordCount) 0)))
(* characterSpacing (sub1 (string-length text))))))
;; create link annotations if the link option is given
(when (· options link)
(send this link x y-in (force renderedWidth) (· this current-line-height) (· options link)))
(let* ([options (send this init-options options x y)]
[text (format "~a" text)] ;; Convert text to a string
;; if the wordSpacing option is specified, remove multiple consecutive spaces
[text (if (hash-ref options 'wordSpacing #f)
(string-replace text #px"\\s{2,}" " ")
text)])
;; word wrapping
(cond
#;[(· options width)
(error 'unimplemented-branch-of-_text)] ; todo
[else ; render paragraphs as single lines
(for ([line (in-list (string-split text "\n"))])
(lineCallback line options))]))
;; create underline or strikethrough line
(when (or (· options underline) (· options strike))
(send this save)
(unless (· options stroke)
(define fill-colorArgs (· this @current-fill-color))
(send this stroke-color . fill-colorArgs))
(define line-width (if (< (· this current-font-size) 10)
0.5
(floor (/ (· this current-font-size) 10))))
(send this line-width line-width)
(define d (if (· options underline) 1 2))
(define lineY (+ y-in (/ (· this current-line-height) d)))
(when (· options underline)
(increment! lineY (- line-width)))
(send this move-to x lineY)
(send this line-to (+ x (force renderedWidth)) lineY)
(send this stroke)
(send this restore))
;; flip coordinate system
(send this save)
(send this transform 1 0 0 -1 0 (· this page height))
(define y (- (· this page height) y-in (* (/ (· this current-font ascender) 1000) (· this current-font-size))))
;; add current font to page if necessary
(hash-ref! (· this page fonts) (· this current-font id) (λ () (· this current-font make-font-ref)))
this)
(define/public (text text-string [x #f] [y #f] [options (mhash)])
(send this _text text-string x y options (λ args (send this _line . args))))
(define/public (string-width str [options (mhash)])
#;(report str 'measuring-width-of)
(+ (send (· this current-font) string-width str (· this current-font-size) (hash-ref options 'features #f))
(* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))
(define/public (init-options [options (mhash)] [x #f] [y #f])
;; clone options object
(let ([options (hash-copy options)])
;; extend options with previous values for continued text
(when (· this _textOptions)
(for ([(key val) (in-hash (· this _textOptions))]
#:unless (equal? (key "continued")))
(hash-ref! options key val)))
;; Update the current position
(when x (set-field! x this x))
(when y (set-field! y this y))
;; wrap to margins if no x or y position passed
(unless (not (hash-ref options 'lineBreak #t))
(define margins (· this page margins))
(hash-ref! options 'width (λ () (- (· this page width) (· this x) (margin-right margins)))))
(hash-ref! options 'columns 0)
(hash-ref! options 'columnGap 18) ; 1/4 inch in PS points
options))
(define/public (_line text [options (mhash)] [wrapper #f])
(send this _fragment text (· this x) (· this y) options)
(define line-gap (or (· options line-gap) (· this _line-gap) 0))
;; 180325 suppress the size tracking: we'll do our own line measurement
;; 181120 unsuppress the size tracking for now because it breaks test 04
(if (not wrapper)
(increment-field! x this (send this string-width text))
(increment-field! y (+ (send this current-line-height #t) line-gap)))
(void))
(define/public (_fragment text x y-in options)
(define align (hash-ref options 'align 'left))
(define wordSpacing (hash-ref options 'wordSpacing 0))
(define characterSpacing (hash-ref options 'characterSpacing 0))
;; text alignments ; todo
;; calculate the actual rendered width of the string after word and character spacing
(define renderedWidth
;; wrap this in delay so it's only calculated if needed
(delay
(+ (or (· options textWidth) (string-width text options))
(* wordSpacing (sub1 (or (· options wordCount) 0)))
(* characterSpacing (sub1 (string-length text))))))
;; create link annotations if the link option is given
(when (· options link)
(send this link x y-in (force renderedWidth) (· this current-line-height) (· options link)))
;; begin the text object
(send this addContent "BT")
;; text position
(send this addContent (format "1 0 0 1 ~a ~a Tm" (number x) (number y)))
;; font and font size
(send this addContent (format "/~a ~a Tf" (· this current-font id) (number (· this current-font-size))))
;; rendering mode
(let ([mode (cond
[(and (hash-ref options 'fill #f) (hash-ref options 'stroke #f)) 2]
[(hash-ref options 'stroke #f) 1]
[else 0])])
(when (and mode (not (zero? mode)))
(send this addContent (format "~a Tr" mode))))
;; Character spacing
(when (not (zero? characterSpacing))
(send this addContent (format "~a Tc" characterSpacing)))
;; Add the actual text
;; If we have a word spacing value, we need to encode each word separately
;; since the normal Tw operator only works on character code 32, which isn't
;; used for embedded fonts.
;; 180321: the first call to this operation is very slow from Quad
;; 181126: because `encode` calls `layout`
(match-define (list encoded-char-strs positions)
(if (not (zero? wordSpacing))
(error 'unimplemented-brach) ; todo
(send (· this current-font) encode text (hash-ref options 'features #f))))
;; create underline or strikethrough line
(when (or (· options underline) (· options strike))
(send this save)
(unless (· options stroke)
(define fill-colorArgs (· this @current-fill-color))
(send this stroke-color . fill-colorArgs))
(define line-width (if (< (· this current-font-size) 10)
0.5
(floor (/ (· this current-font-size) 10))))
(send this line-width line-width)
(define d (if (· options underline) 1 2))
(define lineY (+ y-in (/ (· this current-line-height) d)))
(when (· options underline)
(increment! lineY (- line-width)))
(send this move-to x lineY)
(send this line-to (+ x (force renderedWidth)) lineY)
(send this stroke)
(send this restore))
;; flip coordinate system
(send this save)
(send this transform 1 0 0 -1 0 (· this page height))
(define y (- (· this page height) y-in (* (/ (· this current-font ascender) 1000) (· this current-font-size))))
;; add current font to page if necessary
(hash-ref! (· this page fonts) (· this current-font id) (λ () (· this current-font make-font-ref)))
(define scale (/ (· this current-font-size) 1000.0))
(define commands empty)
(define last 0)
;; begin the text object
(send this addContent "BT")
;; text position
(send this addContent (format "1 0 0 1 ~a ~a Tm" (number x) (number y)))
;; font and font size
(send this addContent (format "/~a ~a Tf" (· this current-font id) (number (· this current-font-size))))
;; rendering mode
(let ([mode (cond
[(and (hash-ref options 'fill #f) (hash-ref options 'stroke #f)) 2]
[(hash-ref options 'stroke #f) 1]
[else 0])])
(when (and mode (not (zero? mode)))
(send this addContent (format "~a Tr" mode))))
;; Character spacing
(when (not (zero? characterSpacing))
(send this addContent (format "~a Tc" characterSpacing)))
;; Add the actual text
;; If we have a word spacing value, we need to encode each word separately
;; since the normal Tw operator only works on character code 32, which isn't
;; used for embedded fonts.
;; 180321: the first call to this operation is very slow from Quad
;; 181126: because `encode` calls `layout`
(match-define (list encoded-char-strs positions)
(if (not (zero? wordSpacing))
(error 'unimplemented-brach) ; todo
(send (· this current-font) encode text (hash-ref options 'features #f))))
;; Adds a segment of text to the TJ command buffer
(define (addSegment cur)
(when (< last cur)
(let* ([hex (string-append* (sublist encoded-char-strs last cur))]
[posn (list-ref positions (sub1 cur))]
[advance (- (glyph-position-x-advance posn) (glyph-position-advance-width posn))])
(push-end! commands (format "<~a> ~a" hex (number (- advance))))))
(set! last cur))
;; Flushes the current TJ commands to the output stream
(define (flush i)
(addSegment i)
(when (positive? (length commands))
(send this addContent (format "[~a] TJ" (string-join commands " ")))
(set! commands empty)))
(define scale (/ (· this current-font-size) 1000.0))
(define commands empty)
(define last 0)
(for/fold ([hadOffset #f] [x x])
([(posn i) (in-indexed positions)])
(define havingOffset
(cond
;; If we have an x or y offset, we have to break out of the current TJ command
;; so we can move the text position.
[(or (not (zero? (glyph-position-x-offset posn))) (not (zero? (glyph-position-y-offset posn))))
;; Flush the current buffer
(flush i)
;; Move the text position and flush just the current character
(send this addContent (format "1 0 0 1 ~a ~a Tm"
(number (+ x (* (glyph-position-x-offset posn) scale)))
(number (+ y (* (glyph-position-y-offset posn) scale)))))
(flush (add1 i))
#t]
[else
;; If the last character had an offset, reset the text position
(when hadOffset
(send this addContent (format "1 0 0 1 ~a ~a Tm" (number x) (number y))))
;; Group segments that don't have any advance adjustments
(unless (zero? (- (glyph-position-x-advance posn) (glyph-position-advance-width posn)))
(addSegment (add1 i)))
#f]))
(values havingOffset (+ x (* (glyph-position-x-advance posn) scale))))
;; Adds a segment of text to the TJ command buffer
(define (addSegment cur)
(when (< last cur)
(let* ([hex (string-append* (sublist encoded-char-strs last cur))]
[posn (list-ref positions (sub1 cur))]
[advance (- (glyph-position-x-advance posn) (glyph-position-advance-width posn))])
(push-end! commands (format "<~a> ~a" hex (number (- advance))))))
(set! last cur))
;; Flushes the current TJ commands to the output stream
(define (flush i)
(addSegment i)
(when (positive? (length commands))
(send this addContent (format "[~a] TJ" (string-join commands " ")))
(set! commands empty)))
(for/fold ([hadOffset #f] [x x])
([(posn i) (in-indexed positions)])
(define havingOffset
(cond
;; If we have an x or y offset, we have to break out of the current TJ command
;; so we can move the text position.
[(or (not (zero? (glyph-position-x-offset posn))) (not (zero? (glyph-position-y-offset posn))))
;; Flush the current buffer
(flush i)
;; Move the text position and flush just the current character
(send this addContent (format "1 0 0 1 ~a ~a Tm"
(number (+ x (* (glyph-position-x-offset posn) scale)))
(number (+ y (* (glyph-position-y-offset posn) scale)))))
(flush (add1 i))
#t]
[else
;; If the last character had an offset, reset the text position
(when hadOffset
(send this addContent (format "1 0 0 1 ~a ~a Tm" (number x) (number y))))
;; Group segments that don't have any advance adjustments
(unless (zero? (- (glyph-position-x-advance posn) (glyph-position-advance-width posn)))
(addSegment (add1 i)))
#f]))
(values havingOffset (+ x (* (glyph-position-x-advance posn) scale))))
;; Flush any remaining commands
(let ([i (length positions)])
(flush i))
;; Flush any remaining commands
(let ([i (length positions)])
(flush i))
;; end the text object
(send this addContent "ET")
;; restore flipped coordinate system
(send this restore)
(void))
;; end the text object
(send this addContent "ET")
;; restore flipped coordinate system
(send this restore)
(void))))

Loading…
Cancel
Save