diff --git a/pitfall/pitfall/afm.rkt b/pitfall/pitfall/afm.rkt index 036817f6..6a832af5 100644 --- a/pitfall/pitfall/afm.rkt +++ b/pitfall/pitfall/afm.rkt @@ -46,12 +46,13 @@ [("FontMetrics") ;; line looks like this: ;; FontName Helvetica - ;; key space value. Possibly multiple lines with same key. + ;; `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 (equal? v value) + (λ (v) (if (eq? v 'init-val) value - (append (if (pair? v) v (list v)) (list value)))) 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 ; @@ -138,78 +139,80 @@ (+ (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}))) +(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}))) (module+ test (define afmfont (AFMFont-open "data/helvetica.afm")) diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 23ab12fa..50ff1b8d 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -42,7 +42,7 @@ (· this initVector) (· this initFonts) (· this initText) - (· this initImages) + ;(· this initImages) (as-methods addPage diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt index ac151899..46426cb0 100644 --- a/pitfall/pitfall/font.rkt +++ b/pitfall/pitfall/font.rkt @@ -68,7 +68,7 @@ (define glyphs (send this-font glyphsForString text)) (define advances (send this-font advancesForGlyphs glyphs)) (define positions - (for/list ([(glyph i) (in-indexed glyphs)] + (for/list ([glyph (in-list glyphs)] [advance (in-list advances)]) (hasheq 'xAdvance advance 'yAdvance 0 diff --git a/pitfall/pitfall/standard-fonts.rkt b/pitfall/pitfall/standard-fonts.rkt index ecacb719..18603d9f 100644 --- a/pitfall/pitfall/standard-fonts.rkt +++ b/pitfall/pitfall/standard-fonts.rkt @@ -1,33 +1,24 @@ #lang pitfall/racket -(require racket/runtime-path (for-syntax racket/base racket/format)) +(require racket/runtime-path (for-syntax racket/base racket/path racket/syntax)) (provide isStandardFont standard-fonts) (define (isStandardFont name) (hash-ref standard-fonts name #f)) -(define-syntax (drps stx) +(define-syntax (define-afm-table stx) (syntax-case stx () - [(_ hashid id ...) - (let ([id-strings (map ~a (map syntax->datum (syntax->list #'(id ...))))]) - (with-syntax ([(path ...) (map (λ (d) (format "data/~a.afm" d)) id-strings)] - [(id-str ...) id-strings]) - #'(begin (define-runtime-path id path) ... - (define hashid (make-hash (list (cons id-str (λ () (file->string id))) ...))))))])) + [(_ hashid dir) + (let* ([path-strings (for/list ([p (in-directory (syntax->datum #'dir) #t)] + #:when (and (file-exists? p) (path-has-extension? p #"afm") p)) + (path->string p))] + [id-strings (for/list ([pstr (in-list path-strings)]) + (path->string (cadr (explode-path (path-replace-extension pstr #"")))))]) + (with-syntax ([(PATH-STR ...) path-strings] + [(ID-STR ...) id-strings] + [(ID ...) (map (λ (id-str) (format-id #'hashid "~a" id-str)) id-strings)]) + #'(begin (define-runtime-path ID PATH-STR) ... + (define hashid (make-hash (list (cons ID-STR (procedure-rename (λ () (file->string ID)) 'ID)) ...))))))])) -(drps 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-afm-table standard-fonts "data") (module+ test