From 30220b42d2b7c286d5b63aaaff684ae2e119f8bf Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 24 Dec 2018 20:42:57 -0800 Subject: [PATCH] methodize afm-font --- pitfall/pitfall/afm-font.rkt | 323 ++++++++++++++---------------- pitfall/pitfall/standard-font.rkt | 14 +- 2 files changed, 152 insertions(+), 185 deletions(-) diff --git a/pitfall/pitfall/afm-font.rkt b/pitfall/pitfall/afm-font.rkt index e255c3ab..f50c1e91 100644 --- a/pitfall/pitfall/afm-font.rkt +++ b/pitfall/pitfall/afm-font.rkt @@ -1,88 +1,92 @@ -#lang at-exp racket/base +#lang racket/base (require racket/class - racket/file racket/match racket/string - racket/contract racket/list - sugar/unstable/class - sugar/unstable/js sugar/unstable/dict) (provide AFMFont AFMFont-open) +(define (AFMFont-open filename) + (make-object AFMFont (open-input-file filename))) + (define AFMFont (class object% (super-new) (init-field contents) - (field [attributes (mhasheq)] - [glyphWidths (mhash)] + (field [@attributes (mhasheq)] + [@glyph-widths (mhash)] [boundingBoxes (mhash)] - [kernPairs (mhash)]) - - (parse this) + [@kern-pairs (mhash)]) + + (for/fold ([last-section #f]) + ([line (in-lines contents)]) + (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) (field [charWidths (for/list ([i (in-range 256)]) - (hash-ref glyphWidths (vector-ref characters i) #f))]) - (field [bbox (for/list ([attr (in-list (string-split (hash-ref attributes 'FontBBox)))]) - (or (string->number attr) 0))]) - (field [ascender (string->number (or (hash-ref attributes 'Ascender #f) "0"))]) - (field [descender (string->number (or (hash-ref attributes 'Descender #f) "0"))]) - (field [line-gap (- (- (list-ref bbox 3) (list-ref bbox 1)) (- ascender descender))]) - - (as-methods - parse - encodeText - glyphsForString - characterToGlyph - advancesForGlyphs - widthOfGlyph - getKernPair) - )) - -(define/contract (AFMFont-open filename) - (path-string? . -> . (is-a?/c AFMFont)) - (make-object AFMFont (file->string filename))) - -(define/contract (parse this) - (->m void?) - (for*/fold ([last-section #f]) - ([line (in-list (string-split (· this contents) "\n"))]) - (define current-section (cond - [(regexp-match #px"^Start(\\w+)" line) => (λ (match) (cadr match))] - [(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! (· this 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! (· this glyphWidths) name width))] - [("KernPairs") - (when (string-prefix? line "KPX") - (match-define (list _ left right val) (string-split line)) - (hash-set! (· this kernPairs) (make-kern-table-key left right) (string->number val)))]) - current-section) - (void)) - -(define (make-kern-table-key left right) - (cons left right)) + (hash-ref @glyph-widths (vector-ref characters i) #f))]) + (field [(@bbox bbox) (for/list ([attr (in-list (string-split (hash-ref @attributes 'FontBBox)))]) + (or (string->number attr) 0))]) + (field [(@ascender ascender) (string->number (or (hash-ref @attributes 'Ascender #f) "0"))]) + (field [(@descender descender) (string->number (or (hash-ref @attributes 'Descender #f) "0"))]) + (field [line-gap (- (list-ref @bbox 3) (list-ref @bbox 1) @ascender @descender)]) + + (define/public (make-kern-table-key left right) + (cons left right)) + + (define/public (encode-text str) + (for/list ([c (in-string str)]) + (define cint (char->integer c)) + (number->string (hash-ref win-ansi-table cint cint) 16))) + + (define/public (glyphs-for-string str) + (for/list ([c (in-string str)]) + (character-to-glyph (char->integer c)))) + + (define/public (character-to-glyph cint) + (define idx (hash-ref win-ansi-table cint cint)) + (vector-ref characters (if (< idx (vector-length characters)) idx 0))) + + (define/public (glyph-width glyph) + (hash-ref @glyph-widths glyph 0)) + + (define/public (get-kern-pair left right) + (hash-ref @kern-pairs (make-kern-table-key left right) 0)) + + (define/public (advances-for-glyphs glyphs) + (for/list ([left (in-list glyphs)] + [right (in-list (append (cdr glyphs) (list #\nul)))]) + (+ (glyph-width left) (get-kern-pair left right)))))) (define win-ansi-table (hasheqv 402 131 @@ -113,117 +117,80 @@ 381 142 382 158)) - -(define/contract (encodeText this str) - (string? . ->m . (listof string?)) - (for/list ([c (in-string str)]) - (define cint (char->integer c)) - (number->string (hash-ref win-ansi-table cint cint) 16))) - - -(define/contract (glyphsForString this str) - (string? . ->m . (listof any/c)) - (for/list ([c (in-string str)]) - (send this characterToGlyph (char->integer c)))) - - -(define/contract (characterToGlyph this cint) - (integer? . ->m . any) - (define idx (hash-ref win-ansi-table cint cint)) - (vector-ref characters (if (< idx (vector-length characters)) idx 0))) - - -(define/contract (widthOfGlyph this glyph) - (string? . ->m . number?) - (hash-ref (· this glyphWidths) glyph 0)) - - -(define/contract (getKernPair this left right) - ((or/c char? string?) (or/c char? string?) . ->m . number?) - (hash-ref (· this kernPairs) (make-kern-table-key left right) 0)) - - -(define/contract (advancesForGlyphs this glyphs) - ((listof any/c) . ->m . (listof number?)) - (for/list ([left (in-list glyphs)] - [right (in-list (append (cdr glyphs) (list #\nul)))]) - (+ (send this widthOfGlyph left) (send this getKernPair left right)))) - - (define characters (list->vector - (string-split - @string-append{ .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}))) + (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)))) (module+ test (define afmfont (AFMFont-open "data/helvetica.afm")) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index fd467be1..a3f9b2c6 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -36,18 +36,18 @@ (send @dictionary end)) (define/override (encode text [options #f]) - (define encoded (send font encodeText text)) - (define glyphs (send font glyphsForString text)) - (define advances (send font advancesForGlyphs glyphs)) + (define encoded (send font encode-text text)) + (define glyphs (send font glyphs-for-string text)) + (define advances (send font advances-for-glyphs glyphs)) (define positions (for/list ([glyph (in-list glyphs)] [advance (in-list advances)]) - (+glyph-position advance 0 0 0 (send font widthOfGlyph glyph)))) + (+glyph-position advance 0 0 0 (send font glyph-width glyph)))) (list encoded positions)) (define/override (string-width str size [options #f]) - (define glyphs (send font glyphsForString str)) - (define advances (send font advancesForGlyphs glyphs)) + (define glyphs (send font glyphs-for-string str)) + (define advances (send font advances-for-glyphs glyphs)) (define width (apply + advances)) (define scale (/ size 1000.0)) (* width scale)))) @@ -62,7 +62,7 @@ [(_ HASH-ID FONT-ID ...) (with-syntax ([(PATH-STR ...) (map (λ (stx) (format "data/~a.afm" (syntax->datum stx))) (syntax->list #'(FONT-ID ...)))]) #'(begin (define-runtime-path FONT-ID PATH-STR) ... - (define HASH-ID (make-hash (list (cons (symbol->string 'FONT-ID) (procedure-rename (λ () (file->string FONT-ID)) 'FONT-ID)) ...)))))])) + (define HASH-ID (make-hash (list (cons (symbol->string 'FONT-ID) (procedure-rename (λ () (open-input-file FONT-ID)) 'FONT-ID)) ...)))))])) (define-afm-table standard-fonts Courier-Bold