From 347b82f9b5ccd44d343c834e7bdea07c3b62dc71 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Wed, 26 Dec 2018 17:30:53 -0800 Subject: [PATCH] gbye --- pitfall/pitfall/afm-font.rkt | 208 --------------------- pitfall/pitfall/font-open.rkt | 3 +- pitfall/pitfall/helper.rkt | 27 --- pitfall/pitfall/png.rkt | 1 - pitfall/pitfall/standard-font.rkt | 288 +++++++++++++++++++++++------- 5 files changed, 229 insertions(+), 298 deletions(-) delete mode 100644 pitfall/pitfall/afm-font.rkt delete mode 100644 pitfall/pitfall/helper.rkt diff --git a/pitfall/pitfall/afm-font.rkt b/pitfall/pitfall/afm-font.rkt deleted file mode 100644 index 3dfbea70..00000000 --- a/pitfall/pitfall/afm-font.rkt +++ /dev/null @@ -1,208 +0,0 @@ -#lang debug racket/base -(require - racket/class - racket/match - racket/string - racket/list - with-cache) - -(provide AFMFont AFMFont-open) - -(define (AFMFont-open filename) - (make-object AFMFont (open-input-file filename))) - -(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 AFMFont - (class object% - (super-new) - (init-field input-file) - - (match-define (list atts gws kps) (parse-afm input-file)) - (field [@attributes (make-hasheq atts)] - [@glyph-widths (make-hash gws)] - [@kern-pairs (make-hash kps)]) - - (field [charWidths (for/list ([i (in-range 256)]) - (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 (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 - 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)))) - -(module+ test - (define afmfont (AFMFont-open "data/helvetica.afm")) - afmfont) \ No newline at end of file diff --git a/pitfall/pitfall/font-open.rkt b/pitfall/pitfall/font-open.rkt index f25c1483..e1b6e119 100644 --- a/pitfall/pitfall/font-open.rkt +++ b/pitfall/pitfall/font-open.rkt @@ -9,8 +9,7 @@ (define (PDFFont-open src family id) (cond - [(and (string? src) (isStandardFont src)) - (make-object StandardFont src id)] + [(and (string? src) (standard-font? src)) (make-object StandardFont src id)] [else (define font (cond diff --git a/pitfall/pitfall/helper.rkt b/pitfall/pitfall/helper.rkt deleted file mode 100644 index 14064c40..00000000 --- a/pitfall/pitfall/helper.rkt +++ /dev/null @@ -1,27 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string racket/format racket/contract) -(provide (all-defined-out) push! pop!) - -(struct exn:pitfall:test exn (data)) - -(define (raise-test-exn val) - (raise (exn:pitfall:test "pitfall test exn" (current-continuation-marks) val))) - -(define-syntax-rule (test-when cond expr) - (if cond (raise-test-exn expr) expr)) - - -(define (color-string? x) - (and (string? x) - (if (string-prefix? x "#") - (or (= (string-length x) 4) (= (string-length x) 7)) - #t))) - - -(define (layout? x) - (and (hash? x) (hash-has-key? x 'glyphs) (hash-has-key? x 'positions))) - -(define index? (and/c number? integer? (not/c negative?))) - - - \ No newline at end of file diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index 4b8e3bb2..ba330e77 100644 --- a/pitfall/pitfall/png.rkt +++ b/pitfall/pitfall/png.rkt @@ -95,7 +95,6 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee (ref-write ($img-ref png) ($png-img-data png)) (ref-end ($img-ref png))) - (define (split-alpha-channel png) (define ip ($img-data png)) (file-position ip 0) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index b55e9338..39ca4883 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -1,91 +1,259 @@ #lang racket/base (require - (for-syntax racket/base) racket/class - racket/file + racket/string + racket/match sugar/unstable/dict - "afm-font.rkt" "font.rkt" "core.rkt" "reference.rkt" fontland - racket/runtime-path) -(provide isStandardFont standard-fonts StandardFont) + racket/runtime-path + racket/list + with-cache) + +(provide standard-font? StandardFont) + +(define-runtime-path here ".") (define StandardFont (class PDFFont (init-field name id) - (field [font (make-object AFMFont - ((hash-ref standard-fonts name - (λ () (raise-argument-error 'PDFFont "valid font name" name)))))]) - (super-new [ascender (get-field ascender font)] - [descender (get-field descender font)] - [bbox (get-field bbox font)] - [line-gap (get-field line-gap font)]) - - (inherit-field [@ascender ascender] - [@descender descender] - [@line-gap line-gap] - [@bbox bbox] - [@dictionary dictionary]) + + (match-define (list atts gws kps) (parse-afm (open-input-file (build-path here (format "data/~a.afm" name))))) + (field [@attributes (make-hasheq atts)] + [@glyph-widths (make-hash gws)] + [@kern-pairs (make-hash kps)]) + + (let* ([ascender (string->number (hash-ref @attributes 'Ascender "0"))] + [descender (string->number (hash-ref @attributes 'Descender "0"))] + [bbox (for/list ([attr (in-list (string-split (hash-ref @attributes 'FontBBox)))]) + (or (string->number attr) 0))] + [line-gap (- (list-ref bbox 3) (list-ref bbox 1) ascender descender)]) + (super-new [ascender ascender] [descender descender] [bbox bbox] [line-gap line-gap])) + + (inherit-field [@dictionary dictionary]) (define/override (embed) (set-$ref-payload! @dictionary - (mhash 'Type 'Font - 'BaseFont (string->symbol name) - 'Subtype 'Type1 - 'Encoding 'WinAnsiEncoding)) + (mhash 'Type 'Font + 'BaseFont (string->symbol name) + 'Subtype 'Type1 + 'Encoding 'WinAnsiEncoding)) (ref-end @dictionary)) + (define/public (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/public (glyphs-for-string str) + (for/list ([c (in-string str)]) + (character-to-glyph c))) + + (define/public (glyph-width glyph) + (hash-ref @glyph-widths glyph 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/public (get-kern-pair left right) + (hash-ref @kern-pairs (make-kern-table-key left right) 0)) + (define/override (encode text [options #f]) - (define encoded (send font encode-text text)) - (define glyphs (send font glyphs-for-string text)) - (define advances (send font advances-for-glyphs glyphs)) + (define encoded (for/list ([c (in-string text)]) + (define cint (char->integer c)) + (number->string (hash-ref win-ansi-table cint cint) 16))) + (define glyphs (glyphs-for-string text)) (define positions (for/list ([glyph (in-list glyphs)] - [advance (in-list advances)]) - (+glyph-position advance 0 0 0 (send font glyph-width glyph)))) + [advance (in-list (advances-for-glyphs glyphs))]) + (+glyph-position advance 0 0 0 (glyph-width glyph)))) (list encoded positions)) (define/override (string-width str size [options #f]) - (define glyphs (send font glyphs-for-string str)) - (define advances (send font advances-for-glyphs glyphs)) - (define width (apply + advances)) + (define glyphs (glyphs-for-string str)) + (define width (apply + (advances-for-glyphs glyphs))) (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) (and (member name standard-fonts) #t)) + (module+ test + (require rackunit) + (check-true (standard-font? "Helvetica")) + (check-true (standard-font? "Courier")) + (check-true (standard-font? "ZapfDingbats")) + (check-false (standard-font? "Not A Font Name")) + (define stdfont (make-object StandardFont "Helvetica" #f))) -(define (isStandardFont name) (hash-ref standard-fonts name #f)) - -(define-syntax (define-afm-table stx) - (syntax-case stx () - [(_ 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 (λ () (open-input-file FONT-ID)) 'FONT-ID)) ...)))))])) - -(define-afm-table standard-fonts - 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 (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)))) -(module+ test - (require rackunit) - (check-true (and (isStandardFont "Helvetica") #t)) - (check-true (and (isStandardFont "Courier") #t)) - (check-true (and (isStandardFont "ZapfDingbats") #t)) - (check-false (isStandardFont "Not A Font Name")))