diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt index 5a5ac8eb..4d2f9c73 100644 --- a/pitfall/pitfall/font.rkt +++ b/pitfall/pitfall/font.rkt @@ -13,11 +13,13 @@ finalize) )) -(define (PDFFont-open document src family id) +(define/contract (PDFFont-open document src family id) + (object? any/c any/c any/c . -> . (is-a?/c PDFFont)) (cond - [(string? src) - (when (isStandardFont src) - (make-object StandardFont document src id))])) + [(and (string? src) (isStandardFont src) + (make-object StandardFont document src id))] + ;; todo: other font-loading cases + [else (raise-argument-error 'PDFFont-open "loadable font name" src)])) (define/contract (ref this) @@ -37,7 +39,8 @@ (class PDFFont (super-new) (init-field document name id) - (field [font (make-object AFMFont ((hash-ref standard-fonts name)))] + (field [font (make-object AFMFont ((hash-ref standard-fonts name + (λ () (raise-argument-error 'PDFFont "valid font name" name)))))] [ascender (· font ascender)] [descender (· font descender)] [bbox (· font bbox)] @@ -47,6 +50,7 @@ encode widthOfString))) + (define/contract (embed this) (->m void?) (set-field! data (· this dictionary) @@ -76,12 +80,12 @@ (define/contract (widthOfString this str size [options #f]) ((string? number?) ((or/c hash? #f)) . ->*m . number?) - (let* ([this-font (· this font)] - [glyphs (send this-font glyphsForString str)] - [advances (send this-font advancesForGlyphs glyphs)] - [width (apply + advances)] - [scale (/ size 1000)]) - (* width scale))) + (define this-font (· this font)) + (define glyphs (send this-font glyphsForString str)) + (define advances (send this-font advancesForGlyphs glyphs)) + (define width (apply + advances)) + (define scale (/ size 1000)) + (* width scale)) (module+ test diff --git a/pitfall/pitfall/font/standard-fonts.rkt b/pitfall/pitfall/font/standard-fonts.rkt index f8c6beb8..ecacb719 100644 --- a/pitfall/pitfall/font/standard-fonts.rkt +++ b/pitfall/pitfall/font/standard-fonts.rkt @@ -1,16 +1,38 @@ #lang pitfall/racket -(require racket/runtime-path) +(require racket/runtime-path (for-syntax racket/base racket/format)) (provide isStandardFont standard-fonts) -(define (isStandardFont name) - (hash-ref standard-fonts name #f)) +(define (isStandardFont name) (hash-ref standard-fonts name #f)) -(define-runtime-path Helvetica "data/Helvetica.afm") +(define-syntax (drps 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))) ...))))))])) + +(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 standard-fonts - (hash "Helvetica" (λ () (file->string Helvetica)))) (module+ test (require rackunit) (check-true (and (isStandardFont "Helvetica") #t)) - (check-false (isStandardFont "Not A Font Name"))) \ No newline at end of file + (check-true (and (isStandardFont "Courier") #t)) + (check-true (and (isStandardFont "ZapfDingbats") #t)) + (check-false (isStandardFont "Not A Font Name")))