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/pitfall/pitfall/text.rkt

252 lines
8.3 KiB
Racket

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

#lang pitfall/racket
(require sugar/list)
(provide text-mixin)
(define (text-mixin [% mixin-tester%])
(class %
(super-new)
(field [_lineGap #f]
[_textOptions #f])
(as-methods
initText
_initOptions
_text
_fragment
text
widthOfString)))
(define/contract (initText this)
(->m void?)
(set-field! x this 0)
(set-field! y this 0)
(lineGap this 0)
(void))
(define/contract (lineGap this _lineGap)
(number? . ->m . object?)
(set-field! _lineGap this _lineGap)
this)
(define/contract (moveDown this [lines 1] #:factor [factor 1])
(() (number? #:factor number?) . ->*m . object?)
(increment-field! y this (* factor (send this currentLineHeight #t) (+ lines (· this _lineGap))))
this)
(define/contract (moveUp this [lines 1])
(() (number?) . ->*m . object?)
(moveDown 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 _initOptions 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 (curry _line this)))
(define/contract (widthOfString this str [options (mhash)])
((string?) (hash?) . ->*m . number?)
(+ (send (· this _font) widthOfString str (· this _fontSize) (hash-ref options 'features #f))
(* (hash-ref options 'characterSpacing 0) (sub1 (string-length str)))))
(define/contract (_initOptions 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) (· margins right)))))
(hash-ref! options 'columns 0)
(hash-ref! options 'columnGap 18) ; 1/4 inch in PS points
options))
(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 lineGap (or (· options lineGap) (· this _lineGap) 0))
(if (not wrapper)
(increment-field! x this (send this widthOfString text))
(increment-field! y (+ (send this currentLineHeight #t) lineGap)))
(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
(+ (or (· options textWidth)
(widthOfString 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 renderedWidth (· this currentLineHeight) (· options link)))
;; create underline or strikethrough line
(when (or (· options underline) (· options strike))
(send this save)
(unless (· options stroke)
(define fillColorArgs (· this _fillColor))
(send this strokeColor . fillColorArgs))
(define lineWidth (if (< (· this _fontSize) 10)
0.5
(floor (/ (· this _fontSize) 10))))
(send this lineWidth lineWidth)
(define d (if (· options underline) 1 2))
(define lineY (+ y-in (/ (· this currentLineHeight) d)))
(when (· options underline)
(increment! lineY (- lineWidth)))
(send this moveTo x lineY)
(send this lineTo (+ x 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 _font ascender) 1000) (· this _fontSize))))
;; add current font to page if necessary
(hash-ref! (· this page fonts) (· this _font id) (λ () (· this _font ref)))
;; 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 _font id) (number (· this _fontSize))))
;; 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.
(match-define (list encoded-char-strs positions)
(if (not (zero? wordSpacing))
(error 'unimplemented-brach) ; todo
(send (· this _font) encode text (hash-ref options 'features #f))))
(define scale (/ (· this _fontSize) 1000.0))
(define commands empty)
(define last 0)
;; 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 (- (· posn xAdvance) (· posn advanceWidth))])
(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? (· posn xOffset))) (not (zero? (· posn yOffset))))
;; 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 (* (· posn xOffset) scale)))
(number (+ y (* (· posn yOffset) 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? (- (· posn xAdvance) (· posn advanceWidth)))
(addSegment (add1 i)))
#f]))
(values havingOffset (+ x (* (· posn xAdvance) scale))))
;; 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))