|
|
#lang pitfall/racket
|
|
|
(require "font.rkt" "glyph-position.rkt" "glyphrun.rkt" "subset.rkt" "reference.rkt")
|
|
|
(provide EmbeddedFont)
|
|
|
|
|
|
(define-subclass PDFFont (EmbeddedFont document font id)
|
|
|
(super-new)
|
|
|
(field [subset (· this font createSubset)]
|
|
|
;; we make `unicode` and `width` fields integer-keyed hashes not lists
|
|
|
;; because they offer better random access and growability
|
|
|
[unicode (mhash 0 '(0))] ; always include the missing glyph (gid = 0)
|
|
|
[widths (mhash 0 (send (send (· this font) getGlyph 0) advanceWidth))]
|
|
|
;; always include the width of the missing glyph (gid = 0)
|
|
|
|
|
|
[name (· font postscriptName)]
|
|
|
[scale (/ 1000 (· font unitsPerEm))]
|
|
|
[ascender (* (· font ascent) scale)]
|
|
|
[descender (* (· font descent) scale)]
|
|
|
[lineGap (* (· font lineGap) scale)]
|
|
|
[bbox (· font bbox)])
|
|
|
|
|
|
(as-methods
|
|
|
widthOfString
|
|
|
encode
|
|
|
embed
|
|
|
toUnicodeCmap))
|
|
|
|
|
|
(define/contract (widthOfString this str size [features #f])
|
|
|
((string? number?) ((or/c list? #f)) . ->*m . number?)
|
|
|
#|
|
|
|
PDFKit makes a whole layout here and measures that.
|
|
|
For now, we'll just measure width of the characters.
|
|
|
|#
|
|
|
#;(define run (send (· this font) layout string)) ; todo: features would be passed here
|
|
|
#;(define width (· run advanceWidth))
|
|
|
#;(define scale (/ size (· this font unitsPerEm)))
|
|
|
#;(* width scale)
|
|
|
(send (· this font) measure-string str size))
|
|
|
|
|
|
|
|
|
;; called from text.rkt
|
|
|
(define/contract (encode this text [features #f])
|
|
|
((string?) ((or/c list? #f)) . ->*m .
|
|
|
(list/c (listof string?) (listof (is-a?/c GlyphPosition))))
|
|
|
(define glyphRun (send (· this font) layout text features))
|
|
|
(define glyphs (· glyphRun glyphs))
|
|
|
(define positions (· glyphRun positions))
|
|
|
(define-values (subset-idxs new-positions)
|
|
|
(for/lists (idxs posns)
|
|
|
([(glyph i) (in-indexed glyphs)]
|
|
|
[posn (in-list positions)])
|
|
|
(define gid (send (· this subset) includeGlyph (· glyph id)))
|
|
|
(define subset-idx (toHex gid))
|
|
|
(set-field! advanceWidth posn (· glyph advanceWidth))
|
|
|
|
|
|
(hash-ref! (· this widths) gid (λ () (· posn advanceWidth)))
|
|
|
(hash-ref! (· this unicode) gid (λ () (· glyph codePoints)))
|
|
|
|
|
|
(send posn scale (· this scale))
|
|
|
(values subset-idx posn)))
|
|
|
(list subset-idxs new-positions))
|
|
|
|
|
|
(require racket/runtime-path)
|
|
|
(define-runtime-path charter-path "test/assets/charter.ttf")
|
|
|
|
|
|
(define/contract (embed this)
|
|
|
(->m void?)
|
|
|
(define isCFF (is-a? (· this subset) CFFSubset))
|
|
|
(define fontFile (· this document ref))
|
|
|
|
|
|
(when isCFF
|
|
|
(hash-set! (· fontFile payload) 'Subtype "CIDFontType0C"))
|
|
|
|
|
|
;; todo
|
|
|
;; (send (send (· this subset) encodeStream) pipe fontFile)
|
|
|
(send fontFile end (send (· this subset) encode)) ;; temp
|
|
|
|
|
|
;; todo
|
|
|
;; (define familyClass (send (· this font) has-table? #"OS/2"))
|
|
|
(define familyClass 0)
|
|
|
|
|
|
;; todo: flags
|
|
|
(define flags 0)
|
|
|
|
|
|
;; generate a random tag (6 uppercase letters. 65 is the char code for 'A')
|
|
|
(when (test-mode) (random-seed 0))
|
|
|
(define tag (list->string (for/list ([i (in-range 6)])
|
|
|
(integer->char (random 65 (+ 65 26))))))
|
|
|
(define name (string-append tag "+" (· this font postscriptName)))
|
|
|
|
|
|
(define bbox (· this font bbox))
|
|
|
(define descriptor (send (· this document) ref
|
|
|
(mhash
|
|
|
'Type "FontDescriptor"
|
|
|
'FontName name
|
|
|
'Flags flags
|
|
|
'FontBBox (map (curry * (· this scale))
|
|
|
(list (· bbox minX) (· bbox minY)
|
|
|
(· bbox maxX) (· bbox maxY)))
|
|
|
'ItalicAngle (· this font italicAngle)
|
|
|
'Ascent (· this ascender)
|
|
|
'Descent (· this descender)
|
|
|
'CapHeight (* (or (· this font capHeight) (· this sfont ascent)) (· this scale))
|
|
|
'XHeight (* (or (· this font xHeight) 0) (· this scale))
|
|
|
'StemV 0)))
|
|
|
|
|
|
|
|
|
(hash-set! (· descriptor payload) (if isCFF
|
|
|
'FontFile3
|
|
|
'FontFile2) fontFile)
|
|
|
|
|
|
(· descriptor end)
|
|
|
#;(report (· descriptor toString) 'descriptor-id)
|
|
|
|
|
|
(define descendantFont (send (· this document) ref
|
|
|
(mhash
|
|
|
'Type "Font"
|
|
|
'Subtype (string-append "CIDFontType" (if isCFF "0" "2"))
|
|
|
'BaseFont name
|
|
|
'CIDSystemInfo
|
|
|
(mhash
|
|
|
'Registry (String "Adobe")
|
|
|
'Ordering (String "Identity")
|
|
|
'Supplement 0)
|
|
|
'FontDescriptor descriptor
|
|
|
'W (list 0 (for/list ([idx (in-range (length (hash-keys (· this widths))))])
|
|
|
(hash-ref (· this widths) idx (λ () (error 'embed (format "hash key ~a not found" idx)))))))))
|
|
|
|
|
|
(· descendantFont end)
|
|
|
#;(report (· descendantFont toString) 'descendantFont)
|
|
|
(hash-set*! (· this dictionary payload)
|
|
|
'Type "Font"
|
|
|
'Subtype "Type0"
|
|
|
'BaseFont name
|
|
|
'Encoding "Identity-H"
|
|
|
'DescendantFonts (list descendantFont)
|
|
|
'ToUnicode (· this toUnicodeCmap))
|
|
|
|
|
|
(· this dictionary end))
|
|
|
|
|
|
|
|
|
(define/contract (toUnicodeCmap this)
|
|
|
(->m (is-a?/c PDFReference))
|
|
|
(define cmap (· this document ref))
|
|
|
(define entries
|
|
|
(for/list ([idx (in-range (length (hash-keys (· this unicode))))])
|
|
|
(define codePoints (hash-ref (· this unicode) idx))
|
|
|
(define encoded ; encode codePoints to utf16
|
|
|
;; todo: full utf16 support. for now just utf8
|
|
|
(for/list ([value (in-list codePoints)])
|
|
|
(toHex value)))
|
|
|
(format "<~a>" (string-join encoded " "))))
|
|
|
|
|
|
(send cmap end @string-append{
|
|
|
/CIDInit /ProcSet findresource begin
|
|
|
12 dict begin
|
|
|
begincmap
|
|
|
/CIDSystemInfo <<
|
|
|
/Registry (Adobe)
|
|
|
/Ordering (UCS)
|
|
|
/Supplement 0
|
|
|
>> def
|
|
|
/CMapName /Adobe-Identity-UCS def
|
|
|
/CMapType 2 def
|
|
|
1 begincodespacerange
|
|
|
<0000><ffff>
|
|
|
endcodespacerange
|
|
|
1 beginbfrange
|
|
|
<0000> <@(toHex (sub1 (length entries)))> [@(string-join entries " ")]
|
|
|
endbfrange
|
|
|
endcmap
|
|
|
CMapName currentdict /CMap defineresource pop
|
|
|
end
|
|
|
end
|
|
|
})
|
|
|
#;(report (· cmap toString) 'cmap-id)
|
|
|
cmap)
|
|
|
|
|
|
(define/contract (toHex . codePoints)
|
|
|
(() () #:rest (listof number?) . ->*m . string?)
|
|
|
(string-append*
|
|
|
(for/list ([code (in-list codePoints)])
|
|
|
(~r code #:base 16 #:min-width 4 #:pad-string "0"))))
|
|
|
|
|
|
|
|
|
(module+ test
|
|
|
(require rackunit "fontkit.rkt" "bbox.rkt")
|
|
|
(define f (openSync "test/assets/Charter.ttf" #f))
|
|
|
(define ef (make-object EmbeddedFont #f f #f))
|
|
|
(check-equal? (send ef widthOfString "f" 1000) 321.0)
|
|
|
(check-equal? (· ef ascender) 980)
|
|
|
(check-equal? (· ef descender) -238)
|
|
|
(check-equal? (· ef lineGap) 0)
|
|
|
(check-equal? (bbox->list (· ef bbox)) '(-161 -236 1193 963))
|
|
|
(define H-gid 41)
|
|
|
(check-equal? (· ef widths) (mhash 0 278))
|
|
|
(check-equal? (send (send (· ef font) getGlyph H-gid) advanceWidth) 738)
|
|
|
|
|
|
) |