#lang debug racket/base (require racket/class racket/string racket/match sugar/unstable/dict "core.rkt" "reference.rkt" fontland racket/runtime-path racket/list with-cache) (provide standard-font-name? make-standard-font) (define-runtime-path here ".") (struct sfont pdf-font (attributes glyph-widths kern-pairs) #:transparent #:mutable) (define (make-standard-font name id) (match-define (list atts gws kps) (parse-afm (open-input-file (build-path here (format "data/~a.afm" name))))) (define attributes (make-hasheq atts)) (define glyph-widths (make-hash gws)) (define kern-pairs (make-hash kps)) (define ascender (string->number (hash-ref attributes 'Ascender "0"))) (define descender (string->number (hash-ref attributes 'Descender "0"))) (define underline-position (string->number (hash-ref attributes 'UnderlinePosition "-100"))) (define underline-thickness (string->number (hash-ref attributes 'UnderlineThickness "50"))) (define bbox (for/list ([attr (in-list (string-split (hash-ref attributes 'FontBBox)))]) (or (string->number attr) 0))) (define line-gap (- (third bbox) (first bbox) ascender descender)) (sfont name id ascender descender underline-position underline-thickness line-gap bbox #f #f sfont-embed sfont-encode sfont-measure-string attributes glyph-widths kern-pairs)) (define (sfont-embed sf) (set-$ref-payload! (pdf-font-ref sf) (mhash 'Type 'Font 'BaseFont (string->symbol (pdf-font-name sf)) 'Subtype 'Type1 'Encoding 'WinAnsiEncoding)) (ref-end (pdf-font-ref sf))) (define (character-to-glyph char) (define cint (char->integer char)) (define idx (hash-ref win-ansi-table cint cint)) (vector-ref characters (if (< idx (vector-length characters)) idx 0))) (define (glyphs-for-string str) (for/list ([c (in-string str)]) (character-to-glyph c))) (define (glyph-width sf glyph) (hash-ref (sfont-glyph-widths sf) glyph 0)) (define (advances-for-glyphs sf glyphs) (if (empty? glyphs) empty (for/list ([left (in-list glyphs)] [right (in-list (append (cdr glyphs) (list #\nul)))]) (+ (glyph-width sf left) (get-kern-pair sf left right))))) (define (get-kern-pair sf left right) (hash-ref (sfont-kern-pairs sf) (make-kern-table-key left right) 0)) (define encoding-cache (make-hash)) (define (sfont-encode sf str [options #f]) (hash-ref encoding-cache str (λ () (define encoded (for/vector ([c (in-string str)]) (define cint (char->integer c)) (number->string (hash-ref win-ansi-table cint cint) 16))) (define glyphs (glyphs-for-string str)) (define positions (for/vector ([glyph (in-list glyphs)] [advance (in-list (advances-for-glyphs sf glyphs))]) (+glyph-position advance 0 0 0 (glyph-width sf glyph)))) (list encoded positions)))) (define (sfont-measure-string sf str size [options #f]) (match-define (list _ posns) (sfont-encode sf str options)) (define width (for/sum ([p (in-vector posns)]) (glyph-position-x-advance p))) (define scale (/ size 1000.0)) (* width scale)) (define standard-fonts (map symbol->string '(Courier-Bold Courier-BoldOblique Courier-Oblique Courier Helvetica-Bold Helvetica-BoldOblique Helvetica-Oblique Helvetica Symbol Times-Bold Times-BoldItalic Times-Italic Times-Roman ZapfDingbats))) (define (standard-font-name? name) (and (string? name) (member name standard-fonts) #t)) (module+ test (require rackunit) (check-true (standard-font-name? "Helvetica")) (check-true (standard-font-name? "Courier")) (check-true (standard-font-name? "ZapfDingbats")) (check-false (standard-font-name? "Not A Font Name")) (define stdfont (make-standard-font "Helvetica" #f))) (define (make-kern-table-key left right) (cons left right)) (define (parse-afm input-file) (parameterize ([*current-cache-keys* (list (λ () (file-or-directory-modify-seconds (path->string (object-name input-file)))))]) (with-cache (path-replace-extension (object-name input-file) #".rktd") (λ () (define @attributes (make-hasheq)) (define @glyph-widths (make-hash)) (define @kern-pairs (make-hash)) (for/fold ([last-section #f] #:result (list (hash->list @attributes) (hash->list @glyph-widths) (hash->list @kern-pairs))) ([line (in-lines input-file)]) (define current-section (cond [(regexp-match #px"(?<=^Start)\\w+" line) => car] [(regexp-match #px"(?<=^End)\\w+" line) #f] [else last-section])) (case current-section [("FontMetrics") ;; line looks like this: ;; FontName Helvetica ;; `key space value`. Possibly multiple lines with same key. (match-define (list _ key value) (regexp-match #px"^(\\w+)\\s+(.*)" line)) (hash-update! @attributes (string->symbol key) (λ (v) (if (eq? v 'init-val) value (append (if (pair? v) v (list v)) (list value)))) 'init-val)] [("CharMetrics") ;; line looks like this: ;; C 33 ; WX 278 ; N exclam ; B 90 0 187 718 ; ;; need to retrieve N and WX fields (when (regexp-match #px"^CH?\\s" line) (define assocs (for/list ([field (in-list (string-split line #px"\\s*;\\s*"))]) (string-split field " "))) (define name (second (assoc "N" assocs))) (define width (string->number (second (assoc "WX" assocs)))) (hash-set! @glyph-widths name width))] [("KernPairs") (when (string-prefix? line "KPX") (match-define (list _ left right val) (string-split line)) (hash-set! @kern-pairs (make-kern-table-key left right) (string->number val)))]) current-section))))) (define win-ansi-table (hasheqv 402 131 8211 150 8212 151 8216 145 8217 146 8218 130 8220 147 8221 148 8222 132 8224 134 8225 135 8226 149 8230 133 8364 128 8240 137 8249 139 8250 155 710 136 8482 153 338 140 339 156 732 152 352 138 353 154 376 159 381 142 382 158)) (define characters (list->vector (map symbol->string '(.notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef .notdef space exclam quotedbl numbersign dollar percent ampersand quotesingle parenleft parenright asterisk plus comma hyphen period slash zero one two three four five six seven eight nine colon semicolon less equal greater question at A B C D E F G H I J K L M N O P Q R S T U V W X Y Z bracketleft backslash bracketright asciicircum underscore grave a b c d e f g h i j k l m n o p q r s t u v w x y z braceleft bar braceright asciitilde .notdef Euro .notdef quotesinglbase florin quotedblbase ellipsis dagger daggerdbl circumflex perthousand Scaron guilsinglleft OE .notdef Zcaron .notdef .notdef quoteleft quoteright quotedblleft quotedblright bullet endash emdash tilde trademark scaron guilsinglright oe .notdef zcaron ydieresis space exclamdown cent sterling currency yen brokenbar section dieresis copyright ordfeminine guillemotleft logicalnot hyphen registered macron degree plusminus twosuperior threesuperior acute mu paragraph periodcentered cedilla onesuperior ordmasculine guillemotright onequarter onehalf threequarters questiondown Agrave Aacute Acircumflex Atilde Adieresis Aring AE Ccedilla Egrave Eacute Ecircumflex Edieresis Igrave Iacute Icircumflex Idieresis Eth Ntilde Ograve Oacute Ocircumflex Otilde Odieresis multiply Oslash Ugrave Uacute Ucircumflex Udieresis Yacute Thorn germandbls agrave aacute acircumflex atilde adieresis aring ae ccedilla egrave eacute ecircumflex edieresis igrave iacute icircumflex idieresis eth ntilde ograve oacute ocircumflex otilde odieresis divide oslash ugrave uacute ucircumflex udieresis yacute thorn ydieresis))))