suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add hinting configuration to `font%'

Browse Source 
The default is that hiniting is enabled, which causes some text
metrics (notably width) to be rounded to integer values, which makes
spacing more consistent. This default is backward-compatible. The
non-default 'unaligned mode refrains from rounding, which makes metric
information scale correctly and improves output for PS/PDF (such as
Redex output).

The `text' function from `slideshow/pict' defaults to
disabling hinting --- which is consistent with its default to combine
text instead of drawing character-by-character -- so slides and Redex
inherit the improvement.
This commit is contained in:
Matthew Flatt 2012-03-27 07:07:16 -06:00
parent 2eeff9d1fc
commit b3002cfab0
8 changed files with 154 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/racket/draw/private/dc.rkt
View File

@ -237,7 +237,8 @@
;; time a font is used in a given map seems to stick, ;; time a font is used in a given map seems to stick,
;; at least for the Quartz and Win32 back-ends. ;; at least for the Quartz and Win32 back-ends.
;; (But we create the font maps on demand.) ;; (But we create the font maps on demand.)
(define font-maps (make-vector 4 #f)) ;; We fold hinting in, too, as an extra factor of 2.
(define font-maps (make-vector 8 #f))
(define (dc-mixin backend%) (define (dc-mixin backend%)
(defclass* dc% backend% (dc<%>) (defclass* dc% backend% (dc<%>)
@ -546,7 +547,7 @@
(define current-smoothing #f) (define current-smoothing #f)
(define (set-font-antialias context smoothing) (define (set-font-antialias context smoothing hinting)
(let ([o (pango_cairo_context_get_font_options context)] (let ([o (pango_cairo_context_get_font_options context)]
[o2 (cairo_font_options_create)]) [o2 (cairo_font_options_create)])
(when o (when o
@ -560,8 +561,13 @@
[(unsmoothed) CAIRO_ANTIALIAS_NONE] [(unsmoothed) CAIRO_ANTIALIAS_NONE]
[(partly-smoothed) CAIRO_ANTIALIAS_GRAY] [(partly-smoothed) CAIRO_ANTIALIAS_GRAY]
[(smoothed) CAIRO_ANTIALIAS_SUBPIXEL])) [(smoothed) CAIRO_ANTIALIAS_SUBPIXEL]))
(cairo_font_options_set_hint_metrics o2 CAIRO_HINT_METRICS_OFF) (case hinting
;; good idea?: (cairo_font_options_set_hint_style o2 CAIRO_HINT_STYLE_NONE) [(aligned)
(cairo_font_options_set_hint_metrics o2 CAIRO_HINT_METRICS_ON)
(cairo_font_options_set_hint_style o2 CAIRO_HINT_STYLE_DEFAULT)]
[(unaligned)
(cairo_font_options_set_hint_metrics o2 CAIRO_HINT_METRICS_OFF)
(cairo_font_options_set_hint_style o2 CAIRO_HINT_STYLE_NONE)])
(pango_cairo_context_set_font_options context o2) (pango_cairo_context_set_font_options context o2)
(cairo_font_options_destroy o2))) (cairo_font_options_destroy o2)))
@ -1220,11 +1226,14 @@
(do-text cr #f s 0 0 use-font combine? offset 0.0)))))) (do-text cr #f s 0 0 use-font combine? offset 0.0))))))
(define/private (get-smoothing-index) (define/private (get-smoothing-index)
(case (dc-adjust-smoothing (send font get-smoothing)) (+ (case (dc-adjust-smoothing (send font get-smoothing))
[(default) 0] [(default) 0]
[(unsmoothed) 1] [(unsmoothed) 1]
[(partly-smoothed) 2] [(partly-smoothed) 2]
[(smoothed) 3])) [(smoothed) 3])
(case (send font get-hinting)
[(aligned) 0]
[(unaligned) 4])))
(define/private (get-context cr smoothing-index) (define/private (get-context cr smoothing-index)
(or (vector-ref contexts smoothing-index) (or (vector-ref contexts smoothing-index)
@ -1236,7 +1245,9 @@
fm))))]) fm))))])
(pango_cairo_update_context cr c) (pango_cairo_update_context cr c)
(vector-set! contexts smoothing-index c) (vector-set! contexts smoothing-index c)
(set-font-antialias c (dc-adjust-smoothing (send font get-smoothing))) (set-font-antialias c
(dc-adjust-smoothing (send font get-smoothing))
(send font get-hinting))
c))) c)))
(define/private (do-text cr draw-mode s x y font combine? offset angle) (define/private (do-text cr draw-mode s x y font combine? offset angle)
@ -1271,7 +1282,9 @@
(cairo_rotate cr (- angle))) (cairo_rotate cr (- angle)))
(let ([desc (get-pango font)] (let ([desc (get-pango font)]
[attrs (send font get-pango-attrs)] [attrs (send font get-pango-attrs)]
[integral round] [force-hinting (case (send font get-hinting)
[(aligned) round]
[else values])]
[x (if rotate? 0.0 (exact->inexact x))] [x (if rotate? 0.0 (exact->inexact x))]
[y (if rotate? 0.0 (exact->inexact y))]) [y (if rotate? 0.0 (exact->inexact y))])
;; We have two ways to draw text: ;; We have two ways to draw text:
@ -1352,7 +1365,8 @@
[else [else
(let ([nw (if blank? (let ([nw (if blank?
0.0 0.0
(integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE))))] (force-hinting
(/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE))))]
[na 0.0]) [na 0.0])
(loop next-s draw-mode measured? (+ w nw) (max h nh) (max d nd) (max a na)))])))])))])) (loop next-s draw-mode measured? (+ w nw) (max h nh) (max d nd) (max a na)))])))])))]))
;; This is character-by-character mode. It uses a cached per-character+font layout ;; This is character-by-character mode. It uses a cached per-character+font layout
@ -1445,10 +1459,10 @@
(memcpy glyph-infos i glyphs 1 _PangoGlyphInfo) (memcpy glyph-infos i glyphs 1 _PangoGlyphInfo)
;; Every glyph is is own cluster: ;; Every glyph is is own cluster:
(ptr-set! log-clusters _int i i) (ptr-set! log-clusters _int i i)
;; Adjust width to be consistent with integral widths ;; Adjust width to be consistent with measured widths
;; used when drawing individual characters. ;; used when drawing individual characters.
;; This is `set-PangoGlyphInfo-width!', but without ;; This is `set-PangoGlyphInfo-width!', but without
;; computing a ;; computing an intermediate pointer:
(ptr-set! glyph-infos _uint32 'abs (+ (* i pgi-size) 4) (vector-ref v 5)) (ptr-set! glyph-infos _uint32 'abs (+ (* i pgi-size) 4) (vector-ref v 5))
(loop (add1 i)))))) (loop (add1 i))))))
;; If we get here, we can use the fast way: ;; If we get here, we can use the fast way:
@ -1482,10 +1496,9 @@
(pango_layout_get_extents layout #f logical) (pango_layout_get_extents layout #f logical)
(let ([baseline (pango_layout_get_baseline layout)] (let ([baseline (pango_layout_get_baseline layout)]
[orig-h (PangoRectangle-height logical)]) [orig-h (PangoRectangle-height logical)])
;; We keep integer width & height to pixel-align each individual character, (let ([lw (force-hinting
;; but we keep non-integral lh & ld to pixel-align the baseline. (/ (PangoRectangle-width logical)
(let ([lw (integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE)))]
(exact->inexact PANGO_SCALE)))]
[flh (/ orig-h (exact->inexact PANGO_SCALE))] [flh (/ orig-h (exact->inexact PANGO_SCALE))]
[ld (/ (- orig-h baseline) (exact->inexact PANGO_SCALE))] [ld (/ (- orig-h baseline) (exact->inexact PANGO_SCALE))]
[la 0.0]) [la 0.0])

5
collects/racket/draw/private/font-syms.rkt
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(provide family-symbol? style-symbol? weight-symbol? smoothing-symbol?) (provide family-symbol? style-symbol? weight-symbol?
smoothing-symbol? hinting-symbol?)
(define (family-symbol? s) (define (family-symbol? s)
(memq s '(default decorative roman script (memq s '(default decorative roman script
@ -15,3 +16,5 @@
(define (smoothing-symbol? s) (define (smoothing-symbol? s)
(memq s '(default smoothed unsmoothed partly-smoothed))) (memq s '(default smoothed unsmoothed partly-smoothed)))
(define (hinting-symbol? s)
(memq s '(aligned unaligned)))

37
collects/racket/draw/private/font.rkt
View File

@ -13,7 +13,7 @@
(provide font% (provide font%
font-list% the-font-list font-list% the-font-list
make-font make-font
family-symbol? style-symbol? weight-symbol? smoothing-symbol? family-symbol? style-symbol? weight-symbol? smoothing-symbol? hinting-symbol?
get-pango-attrs get-pango-attrs
get-face-list get-face-list
(protect-out substitute-fonts? (protect-out substitute-fonts?
@ -186,6 +186,9 @@
(define smoothing 'default) (define smoothing 'default)
(def/public (get-smoothing) smoothing) (def/public (get-smoothing) smoothing)
(define hinting 'aligned)
(def/public (get-hinting) hinting)
(define style 'normal) (define style 'normal)
(def/public (get-style) style) (def/public (get-style) style)
@ -213,14 +216,16 @@
[weight-symbol? [_weight 'normal]] [weight-symbol? [_weight 'normal]]
[any? [_underlined? #f]] [any? [_underlined? #f]]
[smoothing-symbol? [_smoothing 'default]] [smoothing-symbol? [_smoothing 'default]]
[any? [_size-in-pixels? #f]]) [any? [_size-in-pixels? #f]]
[hinting-symbol? [_hinting 'aligned]])
(set! size _size) (set! size _size)
(set! family _family) (set! family _family)
(set! style _style) (set! style _style)
(set! weight _weight) (set! weight _weight)
(set! underlined? _underlined?) (set! underlined? _underlined?)
(set! smoothing _smoothing) (set! smoothing _smoothing)
(set! size-in-pixels? _size-in-pixels?)] (set! size-in-pixels? _size-in-pixels?)
(set! hinting _hinting)]
[([size? _size] [([size? _size]
[(make-or-false string?) _face] [(make-or-false string?) _face]
[family-symbol? _family] [family-symbol? _family]
@ -228,7 +233,8 @@
[weight-symbol? [_weight 'normal]] [weight-symbol? [_weight 'normal]]
[any? [_underlined? #f]] [any? [_underlined? #f]]
[smoothing-symbol? [_smoothing 'default]] [smoothing-symbol? [_smoothing 'default]]
[any? [_size-in-pixels? #f]]) [any? [_size-in-pixels? #f]]
[hinting-symbol? [_hinting 'aligned]])
(set! size _size) (set! size _size)
(set! face (and _face (string->immutable-string _face))) (set! face (and _face (string->immutable-string _face)))
(set! family _family) (set! family _family)
@ -236,7 +242,8 @@
(set! weight _weight) (set! weight _weight)
(set! underlined? _underlined?) (set! underlined? _underlined?)
(set! smoothing _smoothing) (set! smoothing _smoothing)
(set! size-in-pixels? _size-in-pixels?)] (set! size-in-pixels? _size-in-pixels?)
(set! hinting _hinting)]
(init-name 'font%)) (init-name 'font%))
(define id (define id
@ -244,7 +251,7 @@
(send the-font-name-directory find-or-create-font-id face family) (send the-font-name-directory find-or-create-font-id face family)
(send the-font-name-directory find-family-default-font-id family))) (send the-font-name-directory find-family-default-font-id family)))
(define key (define key
(let ([key (vector id size style weight underlined? smoothing size-in-pixels?)]) (let ([key (vector id size style weight underlined? smoothing size-in-pixels? hinting)])
(let ([old-key (atomically (hash-ref keys key #f))]) (let ([old-key (atomically (hash-ref keys key #f))])
(if old-key (if old-key
(weak-box-value old-key) (weak-box-value old-key)
@ -267,8 +274,9 @@
[weight-symbol? [weight 'normal]] [weight-symbol? [weight 'normal]]
[any? [underlined? #f]] [any? [underlined? #f]]
[smoothing-symbol? [smoothing 'default]] [smoothing-symbol? [smoothing 'default]]
[any? [size-in-pixels? #f]]) [any? [size-in-pixels? #f]]
(vector size family style weight underlined? smoothing size-in-pixels?)] [hinting-symbol? [hinting 'aligned]])
(vector size family style weight underlined? smoothing size-in-pixels? hinting)]
[([size? size] [([size? size]
[(make-or-false string?) face] [(make-or-false string?) face]
[family-symbol? family] [family-symbol? family]
@ -276,10 +284,11 @@
[weight-symbol? [weight 'normal]] [weight-symbol? [weight 'normal]]
[any? [underlined? #f]] [any? [underlined? #f]]
[smoothing-symbol? [smoothing 'default]] [smoothing-symbol? [smoothing 'default]]
[any? [size-in-pixels? #f]]) [any? [size-in-pixels? #f]]
[hinting-symbol? [hinting 'aligned]])
(vector size (and face (string->immutable-string face)) family (vector size (and face (string->immutable-string face)) family
style weight underlined? smoothing size-in-pixels?)] style weight underlined? smoothing size-in-pixels? hinting)]
(method-name 'find-or-create-font font-list%))]) (method-name 'find-or-create-font 'font-list%))])
(atomically (atomically
(let ([e (hash-ref fonts key #f)]) (let ([e (hash-ref fonts key #f)])
(or (and e (or (and e
@ -320,11 +329,13 @@
#:weight [weight 'normal] #:weight [weight 'normal]
#:underlined? [underlined? #f] #:underlined? [underlined? #f]
#:smoothing [smoothing 'default] #:smoothing [smoothing 'default]
#:size-in-pixels? [size-in-pixels? #f]) #:size-in-pixels? [size-in-pixels? #f]
#:hinting [hinting 'aligned])
(unless (size? size) (raise-type-error 'make-font "exact integer in [1, 1024]" size)) (unless (size? size) (raise-type-error 'make-font "exact integer in [1, 1024]" size))
(unless (or (not face) (string? face)) (raise-type-error 'make-font "string or #f" face)) (unless (or (not face) (string? face)) (raise-type-error 'make-font "string or #f" face))
(unless (family-symbol? family) (raise-type-error 'make-font "family-symbol" family)) (unless (family-symbol? family) (raise-type-error 'make-font "family-symbol" family))
(unless (style-symbol? style) (raise-type-error 'make-font "style-symbol" style)) (unless (style-symbol? style) (raise-type-error 'make-font "style-symbol" style))
(unless (weight-symbol? weight) (raise-type-error 'make-font "weight-symbol" weight)) (unless (weight-symbol? weight) (raise-type-error 'make-font "weight-symbol" weight))
(unless (smoothing-symbol? smoothing) (raise-type-error 'make-font "smoothing-symbol" smoothing)) (unless (smoothing-symbol? smoothing) (raise-type-error 'make-font "smoothing-symbol" smoothing))
(make-object font% size face family style weight underlined? smoothing size-in-pixels?)) (unless (hinting-symbol? hinting) (raise-type-error 'make-font "hinting-symbol" hinting))
(make-object font% size face family style weight underlined? smoothing size-in-pixels? hinting))

33
collects/scribblings/draw/draw-funcs.scrbl
View File

@ -11,7 +11,7 @@ A parameter that determines the current PostScript configuration
settings. See @racket[post-script-dc%] and @racket[printer-dc%].} settings. See @racket[post-script-dc%] and @racket[printer-dc%].}
@defproc[(get-face-list [kind (one-of/c 'mono 'all) 'all] @defproc[(get-face-list [kind (or/c 'mono 'all) 'all]
[#:all-variants? all-variants? any/c #f]) [#:all-variants? all-variants? any/c #f])
(listof string?)]{ (listof string?)]{
@ -26,8 +26,8 @@ If @racket[all-variants?] is @racket[#f] (the default), then the
includes a string for each available face in the family.} includes a string for each available face in the family.}
@defproc[(get-family-builtin-face [family (one-of/c 'default 'decorative 'roman 'script @defproc[(get-family-builtin-face [family (or/c 'default 'decorative 'roman 'script
'swiss 'modern 'symbol 'system)]) 'swiss 'modern 'symbol 'system)])
string?]{ string?]{
Returns the built-in default face mapping for a particular font Returns the built-in default face mapping for a particular font
@ -50,16 +50,17 @@ See also @racket[make-platform-bitmap] and @secref["Portability"].
@defproc[(make-font [#:size size (integer-in 1 1024) 12] @defproc[(make-font [#:size size (integer-in 1 1024) 12]
[#:face face (or/c string? #f) #f] [#:face face (or/c string? #f) #f]
[#:family family (one-of/c 'default 'decorative 'roman 'script [#:family family (or/c 'default 'decorative 'roman 'script
'swiss 'modern 'symbol 'system) 'swiss 'modern 'symbol 'system)
'default] 'default]
[#:style style (one-of/c 'normal 'italic 'slant) 'normal] [#:style style (or/c 'normal 'italic 'slant) 'normal]
[#:weight weight (one-of/c 'normal 'bold 'light) 'normal] [#:weight weight (or/c 'normal 'bold 'light) 'normal]
[#:underlined? underlined? any/c #f] [#:underlined? underlined? any/c #f]
[#:smoothing smoothing (one-of/c 'default 'partly-smoothed [#:smoothing smoothing (or/c 'default 'partly-smoothed
'smoothed 'unsmoothed) 'smoothed 'unsmoothed)
'default] 'default]
[#:size-in-pixels? size-in-pixels? any/c #f]) [#:size-in-pixels? size-in-pixels? any/c #f]
[#:hinting hinting (or/c 'aligned 'unaligned) 'aligned])
(is-a?/c font%)]{ (is-a?/c font%)]{
Creates a @racket[font%] instance. This procedure provides an Creates a @racket[font%] instance. This procedure provides an
@ -90,12 +91,12 @@ on Windows and Mac OS X. See @secref["Portability"] for more information.}
@defproc[(read-bitmap [in (or path-string? input-port?)] @defproc[(read-bitmap [in (or path-string? input-port?)]
[kind (one-of/c 'unknown 'unknown/mask 'unknown/alpha [kind (or/c 'unknown 'unknown/mask 'unknown/alpha
'gif 'gif/mask 'gif/alpha 'gif 'gif/mask 'gif/alpha
'jpeg 'jpeg/alpha 'jpeg 'jpeg/alpha
'png 'png/mask 'png/alpha 'png 'png/mask 'png/alpha
'xbm 'xbm/alpha 'xpm 'xpm/alpha 'xbm 'xbm/alpha 'xpm 'xpm/alpha
'bmp 'bmp/alpha) 'bmp 'bmp/alpha)
'unknown/alpha] 'unknown/alpha]
[bg-color (or/c (is-a?/c color%) false/c) #f] [bg-color (or/c (is-a?/c color%) false/c) #f]
[complain-on-failure? any/c #t]) [complain-on-failure? any/c #t])

58
collects/scribblings/draw/font-class.scrbl
View File

@ -78,6 +78,14 @@ A @defterm{font} is an object which determines the appearance of text,
bitmap drawing context), @racket[#f] if the size of the font is in bitmap drawing context), @racket[#f] if the size of the font is in
points (which can depend on screen resolution).} points (which can depend on screen resolution).}
@item{hinting --- Whether font metrics should be rounded to integers:
@itemize[
@item{@indexed-racket['aligned] (the default) --- rounds to integers
to improve the consistency of letter spacing for pixel-based
targets, but at the expense of making metrics unscalable}
@item{@indexed-racket['unaligned] --- disables rounding}
]}
] ]
To avoid creating multiple fonts with the same characteristics, use To avoid creating multiple fonts with the same characteristics, use
@ -90,33 +98,37 @@ See also
@defconstructor*/make[(() @defconstructor*/make[(()
([size (integer-in 1 1024)] ([size (integer-in 1 1024)]
[family (one-of/c 'default 'decorative 'roman 'script [family (or/c 'default 'decorative 'roman 'script
'swiss 'modern 'symbol 'system)] 'swiss 'modern 'symbol 'system)]
[style (one-of/c 'normal 'italic 'slant) 'normal] [style (or/c 'normal 'italic 'slant) 'normal]
[weight (one-of/c 'normal 'bold 'light) 'normal] [weight (or/c 'normal 'bold 'light) 'normal]
[underline? any/c #f] [underline? any/c #f]
[smoothing (one-of/c 'default 'partly-smoothed [smoothing (or/c 'default 'partly-smoothed
'smoothed 'unsmoothed) 'smoothed 'unsmoothed)
'default] 'default]
[size-in-pixels? any/c #f]) [size-in-pixels? any/c #f]
[hinting (or/c 'aligned 'unaligned) 'aligned])
([size (integer-in 1 1024)] ([size (integer-in 1 1024)]
[face string?] [face string?]
[family (one-of/c 'default 'decorative 'roman 'script [family (or/c 'default 'decorative 'roman 'script
'swiss 'modern 'symbol 'system)] 'swiss 'modern 'symbol 'system)]
[style (one-of/c 'normal 'italic 'slant) 'normal] [style (or/c 'normal 'italic 'slant) 'normal]
[weight (one-of/c 'normal 'bold 'light) 'normal] [weight (or/c 'normal 'bold 'light) 'normal]
[underline? any/c #f] [underline? any/c #f]
[smoothing (one-of/c 'default 'partly-smoothed [smoothing (or/c 'default 'partly-smoothed
'smoothed 'unsmoothed) 'smoothed 'unsmoothed)
'default] 'default]
[size-in-pixels? any/c #f]))]{ [size-in-pixels? any/c #f]
[hinting (or/c 'aligned 'unaligned) 'aligned]))]{
When no arguments are provided, creates an instance of the default When no arguments are provided, creates an instance of the default
font. If no face name is provided, the font is created without a face font. If no face name is provided, the font is created without a face
name. name.
See @racket[font%] for information about @racket[family], See @racket[font%] for information about @racket[family],
@racket[style], and @racket[weight]. @racket[font-name-directory<%>]. @racket[style], @racket[weight], @racket[smoothing],
@racket[size-in-pixels?], and @racket[hinting].
@racket[font-name-directory<%>].
See also @racket[make-font]. See also @racket[make-font].
@ -130,8 +142,8 @@ Gets the font's face name, or @racket[#f] if none is specified.
} }
@defmethod[(get-family) @defmethod[(get-family)
(one-of/c 'default 'decorative 'roman 'script (or/c 'default 'decorative 'roman 'script
'swiss 'modern 'symbol 'system)]{ 'swiss 'modern 'symbol 'system)]{
Gets the font's family. See @racket[font%] for information about Gets the font's family. See @racket[font%] for information about
families. families.
@ -147,6 +159,14 @@ face and family specifications, only.
} }
@defmethod[(get-hinting)
(or/c 'aligned 'unaligned)]{
Gets the font's hinting. See @racket[font%] for information about
hinting.
}
@defmethod[(get-point-size) @defmethod[(get-point-size)
(integer-in 1 1024)]{ (integer-in 1 1024)]{
@ -172,7 +192,7 @@ For a size in points and a screen or bitmap drawing context, the
} }
@defmethod[(get-smoothing) @defmethod[(get-smoothing)
(one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed)]{ (or/c 'default 'partly-smoothed 'smoothed 'unsmoothed)]{
Gets the font's anti-alias smoothing mode. See @racket[font%] for Gets the font's anti-alias smoothing mode. See @racket[font%] for
information about smoothing. information about smoothing.
@ -180,7 +200,7 @@ Gets the font's anti-alias smoothing mode. See @racket[font%] for
} }
@defmethod[(get-style) @defmethod[(get-style)
(one-of/c 'normal 'italic 'slant)]{ (or/c 'normal 'italic 'slant)]{
Gets the font's slant style. See @racket[font%] for information about Gets the font's slant style. See @racket[font%] for information about
styles. styles.
@ -196,7 +216,7 @@ otherwise.
} }
@defmethod[(get-weight) @defmethod[(get-weight)
(one-of/c 'normal 'bold 'light)]{ (or/c 'normal 'bold 'light)]{
Gets the font's weight. See @racket[font%] for information about Gets the font's weight. See @racket[font%] for information about
weights. weights.

6
collects/scribblings/draw/font-list-class.scrbl
View File

@ -22,7 +22,8 @@ Creates an empty font list.
[weight (one-of/c 'normal 'bold 'light)] [weight (one-of/c 'normal 'bold 'light)]
[underline? any/c #f] [underline? any/c #f]
[smoothing (one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default] [smoothing (one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default]
[size-in-pixels? any/c #f]) [size-in-pixels? any/c #f]
[hinting (or/c 'aligned 'unaligned) 'aligned])
(is-a?/c font%)] (is-a?/c font%)]
[(find-or-create-font [size (integer-in 1 255)] [(find-or-create-font [size (integer-in 1 255)]
[face string?] [face string?]
@ -32,7 +33,8 @@ Creates an empty font list.
[weight (one-of/c 'normal 'bold 'light)] [weight (one-of/c 'normal 'bold 'light)]
[underline any/c #f] [underline any/c #f]
[smoothing (one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default] [smoothing (one-of/c 'default 'partly-smoothed 'smoothed 'unsmoothed) 'default]
[size-in-pixels? any/c #f]) [size-in-pixels? any/c #f]
[hinting (or/c 'aligned 'unaligned) 'aligned])
(is-a?/c font%)])]{ (is-a?/c font%)])]{
Finds an existing font in the list or creates a new one (that is Finds an existing font in the list or creates a new one (that is

13
collects/scribblings/slideshow/picts.scrbl
View File

@ -189,11 +189,20 @@ The @racket[style] argument must be one of the following:
(the default, unless the @racket['modern] family is specified)} (the default, unless the @racket['modern] family is specified)}
@item{@racket[(cons 'no-combine style)] --- renders characters individually} @item{@racket[(cons 'no-combine style)] --- renders characters individually}
@item{@racket[(cons 'aligned style)] --- enables hinting, which
rounds metrics to integers}
@item{@racket[(cons 'unaligned style)] --- disables hinting (which is
the default), so that metrics are scalable}
] ]
If both @racket['combine] and @racket['no-combine] are specified, the If both @racket['combine] and @racket['no-combine] are specified, the
first one takes precedence. If caps is specified, the angle must be first one in @racket[style] takes precedence. Similarly, if both
zero. @racket['aligned] and @racket['unaligned] are specified, the first one
in !racket[style] takes precedence. If @racket['caps] is specified,
the @racket[angle] must be zero.
The given @racket[size] is in pixels, but it is ignored if a The given @racket[size] is in pixels, but it is ignored if a
@racket[font%] object is provided in the text-style. @racket[font%] object is provided in the text-style.

35
collects/texpict/private/mrpict-extra.rkt
View File

@ -90,7 +90,7 @@
(memq* a (cdr l))) (memq* a (cdr l)))
#f)) #f))
(define (extend-font font size style weight) (define (extend-font font size style weight hinting)
(if (send font get-face) (if (send font get-face)
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
size size
@ -100,7 +100,8 @@
weight weight
#f #f
'default 'default
#t) #t
hinting)
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
size size
(send font get-family) (send font get-family)
@ -108,7 +109,8 @@
weight weight
#f #f
'default 'default
#t))) #t
hinting)))
(define text (define text
(case-lambda (case-lambda
@ -142,25 +144,26 @@
(cond (cond
[(null? style) [(null? style)
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
size 'default 'normal 'normal #f 'default #t)] size 'default 'normal 'normal #f 'default #t 'unaligned)]
[(is-a? style font%) [(is-a? style font%)
style] style]
[(memq style families) [(memq style families)
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
size style 'normal 'normal #f 'default #t)] size style 'normal 'normal #f 'default #t 'unaligned)]
[(string? style) [(string? style)
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
size style 'default 'normal 'normal #f 'default #t)] size style 'default 'normal 'normal #f 'default #t 'unaligned)]
[(and (pair? style) [(and (pair? style)
(string? (car style)) (string? (car style))
(memq (cdr style) families)) (memq (cdr style) families))
(send the-font-list find-or-create-font (send the-font-list find-or-create-font
size (car style) (cdr style) 'normal 'normal #f 'default #t)] size (car style) (cdr style) 'normal 'normal #f 'default #t 'unaligned)]
[(and (pair? style) [(and (pair? style)
(memq (car style) (memq (car style)
'(superscript '(superscript
subscript subscript
bold italic))) bold italic
aligned unaligned)))
(let ([font (loop (cdr style))] (let ([font (loop (cdr style))]
[style (car style)]) [style (car style)])
(cond (cond
@ -168,12 +171,21 @@
(extend-font font (extend-font font
(send font get-point-size) (send font get-point-size)
(send font get-style) (send font get-style)
'bold)] 'bold
(send font get-hinting))]
[(eq? style 'italic) [(eq? style 'italic)
(extend-font font (extend-font font
(send font get-point-size) (send font get-point-size)
'italic 'italic
(send font get-weight))] (send font get-weight)
(send font get-hinting))]
[(or (eq? style 'aligned)
(eq? style 'unaligned))
(extend-font font
(send font get-point-size)
(send font get-style)
(send font get-weight)
style)]
[else font]))] [else font]))]
[(and (pair? style) [(and (pair? style)
(memq (car style) '(combine no-combine))) (memq (car style) '(combine no-combine)))
@ -194,7 +206,8 @@
(extend-font font (extend-font font
(floor (* 6/10 (send font get-point-size))) (floor (* 6/10 (send font get-point-size)))
(send font get-style) (send font get-style)
(send font get-weight)) (send font get-weight)
(send font get-hinting))
font)] font)]
[dc (dc-for-text-size)]) [dc (dc-for-text-size)])
(unless dc (unless dc