From ff57455150f99ea87ce4702acc284e4be119145d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Aug 2010 11:06:02 -0600 Subject: [PATCH] manual font substitution for Mac OS X --- collects/mred/private/fontdialog.rkt | 4 +- collects/mred/private/wxme/snip.rkt | 10 +-- collects/racket/draw/dc.rkt | 117 +++++++++++++++++++++------ collects/racket/draw/pango.rkt | 15 ++++ src/mac/README.txt | 60 +++++++++++++- src/mac/install-libs.rkt | 2 +- 6 files changed, 169 insertions(+), 39 deletions(-) diff --git a/collects/mred/private/fontdialog.rkt b/collects/mred/private/fontdialog.rkt index 9e58232e0a..5ba477a5db 100644 --- a/collects/mred/private/fontdialog.rkt +++ b/collects/mred/private/fontdialog.rkt @@ -52,7 +52,9 @@ [sip (make-object check-box% "Size in Pixels" p4 refresh-sample)] [sym (make-object check-box% "Map as Symbol" p4 refresh-sample)] [size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)] - [sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))] + [sample (make-object text-field% "Sample" f void + "The quick brown fox jumped over the lazy dog\n(\u3bb (x) x)\n" + '(multiple))] [edit (send sample get-editor)] [done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))] [get-font (lambda () (let ([face (send face get-string-selection)]) diff --git a/collects/mred/private/wxme/snip.rkt b/collects/mred/private/wxme/snip.rkt index c970389b20..ef08a0b633 100644 --- a/collects/mred/private/wxme/snip.rkt +++ b/collects/mred/private/wxme/snip.rkt @@ -444,15 +444,7 @@ [real? left] [real? top] [real? bottom] [real? right] [real? dx] [real? dy] [symbol? caret]) (unless (has-flag? s-flags INVISIBLE) - (send dc draw-text (replace-nuls (substring s-buffer s-dtext (+ s-dtext s-count))) x y #f) - (when (eq? (system-type) 'unix) - (when (send s-style get-underlined) - (let ([descent (send s-style get-text-descent dc)] - [h (send s-style get-text-height dc)]) - (let ([y (if (descent . >= . 2) - (+ y (- h (/ descent 2))) - (+ y (- h descent)))]) - (send dc draw-line x y (+ x str-w) y))))))) + (send dc draw-text (replace-nuls (substring s-buffer s-dtext (+ s-dtext s-count))) x y #f))) (def/override (split [exact-nonnegative-integer? position] [box? first] [box? second]) (let ([count s-count]) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index f9ac887fb5..4124a6ba7a 100644 --- a/collects/racket/draw/dc.rkt +++ b/collects/racket/draw/dc.rkt @@ -921,28 +921,59 @@ [x (if rotate? 0.0 x)] [y (if rotate? 0.0 y)]) (if combine? - (let ([layout (pango_layout_new context)]) - (pango_layout_set_font_description layout desc) - (when attrs (pango_layout_set_attributes layout attrs)) - (pango_layout_set_text layout s) - (when draw? - (cairo_move_to cr x y) - (pango_cairo_show_layout cr layout)) - (begin0 - (if draw? - (void) - (let ([logical (make-PangoRectangle 0 0 0 0)]) - (pango_layout_get_extents layout #f logical) - (values (if blank? - 0.0 - (integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE)))) - (integral (/ (PangoRectangle-height logical) (exact->inexact PANGO_SCALE))) - (integral (/ (- (PangoRectangle-height logical) - (pango_layout_get_baseline layout)) - (exact->inexact PANGO_SCALE))) - 0.0))) - (g_object_unref layout) - (when rotate? (cairo_restore cr)))) + (let loop ([s s] [w 0.0] [h 0.0] [d 0.0] [a 0.0]) + (cond + [(not s) + (when rotate? (cairo_restore cr)) + (values w h d a)] + [else + (let ([layout (pango_layout_new context)] + [next-s #f]) + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs)) + (pango_layout_set_text layout s) + (let ([next-s + (if (zero? (pango_layout_get_unknown_glyphs_count layout)) + #f + ;; look for the first character in the string without a glyph + (let ([ok-count + (let ([len (string-length s)]) + (let loop ([lo 0] [hi (sub1 len)] [i (quotient len 2)]) + (cond + [(= lo hi) lo] + [else + (pango_layout_set_text layout (substring s lo i)) + (if (zero? (pango_layout_get_unknown_glyphs_count layout)) + ;; ok so far, so look higher + (if (= i lo) + lo + (loop i hi (+ i (quotient (- hi i) 2)))) + ;; still not ok; look lower + (loop lo i (+ lo (quotient (- i lo) 2))))])))]) + (pango_layout_set_text layout (substring s 0 (max 1 ok-count))) + (when (zero? ok-count) + ;; find a face that works for the long character: + (install-alternate-face layout font desc attrs)) + (substring s (max 1 ok-count))))]) + (when draw? + (cairo_move_to cr (+ x w) y) + (pango_cairo_show_layout cr layout)) + (cond + [(and draw? (not next-s)) + (g_object_unref layout) + (void)] + [else + (let ([logical (make-PangoRectangle 0 0 0 0)]) + (pango_layout_get_extents layout #f logical) + (let ([nw (if blank? + 0.0 + (integral (/ (PangoRectangle-width logical) (exact->inexact PANGO_SCALE))))] + [nh (integral (/ (PangoRectangle-height logical) (exact->inexact PANGO_SCALE)))] + [nd (integral (/ (- (PangoRectangle-height logical) + (pango_layout_get_baseline layout)) + (exact->inexact PANGO_SCALE)))] + [na 0.0]) + (loop next-s (+ w nw) (max h nh) (max d nd) (max a na))))])))])) (let ([logical (make-PangoRectangle 0 0 0 0)]) (begin0 (for/fold ([w 0.0][h 0.0][d 0.0][a 0.0]) @@ -955,10 +986,12 @@ (pango_layout_set_font_description layout desc) (when attrs (pango_layout_set_attributes layout attrs)) (pango_layout_set_text layout (string ch)) + (unless (zero? (pango_layout_get_unknown_glyphs_count layout)) + ;; No good glyph; look for an alternate face + (install-alternate-face layout font desc attrs)) (hash-set! layouts key layout) layout)))]) (pango_cairo_update_layout cr layout) - ;; (cairo_show_glyphs cr (make-cairo_glyph_t 65 x y) 1) (when draw? (cairo_move_to cr (+ x w) y) (pango_cairo_show_layout cr layout)) @@ -971,6 +1004,29 @@ [la 0.0]) (values (if blank? 0.0 (+ w lw)) (max h lh) (max d ld) (max a la))))) (when rotate? (cairo_restore cr)))))))) + + + (define/private (install-alternate-face layout font desc attrs) + (or + (for/or ([face (in-list (get-face-list))]) + (let ([desc (get-pango (make-object font% + (send font get-point-size) + face + (send font get-family) + (send font get-style) + (send font get-weight) + (send font get-underlined) + (send font get-smoothing) + (send font get-size-in-pixels)))]) + (and desc + (let ([attrs (send font get-pango-attrs)]) + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs)) + (zero? (pango_layout_get_unknown_glyphs_count layout)))))) + (begin + ;; put old desc & attrs back + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs))))) (def/public (get-char-width) 10.0) @@ -1138,7 +1194,20 @@ (send tmp-dc set-bitmap #f) tmp-bm)) - (def/public (glyph-exists? [char? c]) #t) + (def/public (glyph-exists? [char? c]) + (with-cr + #f + cr + (let ([desc (get-pango font)]) + (unless context + (set! context (pango_cairo_create_context cr))) + (let ([layout (pango_layout_new context)]) + (pango_layout_set_font_description layout desc) + (pango_layout_set_text layout (string c)) + (pango_cairo_update_layout cr layout) + (begin0 + (zero? (pango_layout_get_unknown_glyphs_count layout)) + (g_object_unref layout)))))) ) dc%) \ No newline at end of file diff --git a/collects/racket/draw/pango.rkt b/collects/racket/draw/pango.rkt index d09160ac15..07d972db31 100644 --- a/collects/racket/draw/pango.rkt +++ b/collects/racket/draw/pango.rkt @@ -47,9 +47,12 @@ (define PangoLayout (_cpointer 'PangoLayout)) (define PangoFontDescription (_cpointer 'PangoFontDescription)) (define PangoFontFamily (_cpointer 'PangoFontFamily)) +(define PangoFont (_cpointer 'PangoFont)) (define PangoFontMap (_cpointer 'PangoFontMap)) (define PangoAttrList (_cpointer 'PangoAttrList)) (define PangoAttribute (_cpointer 'PangoAttribute)) +(define PangoLanguage (_cpointer 'PangoLanguage)) +(define PangoCoverage (_cpointer 'PangoCoverage)) (define-cstruct _PangoRectangle ([x _int] [y _int] @@ -88,6 +91,16 @@ (define-pango pango_font_family_get_name (_fun PangoFontFamily -> _string)) ;; not an allocator (define-pango pango_font_family_is_monospace (_fun PangoFontFamily -> _bool)) +(define-pango pango_language_get_default (_fun -> PangoLanguage)) +(define-pango pango_font_map_load_font (_fun PangoFontMap PangoContext PangoFontDescription -> (_or-null PangoFont))) +(define-pango pango_coverage_unref (_fun PangoCoverage -> _void) + #:wrap (deallocator)) +(define-pango pango_font_get_coverage (_fun PangoFont PangoLanguage -> PangoCoverage) + #:wrap (allocator pango_coverage_unref)) +(define-pango pango_coverage_get (_fun PangoCoverage _int -> _int)) + +(define-pango pango_layout_get_unknown_glyphs_count (_fun PangoLayout -> _int)) + (define-pango pango_attr_list_unref (_fun PangoAttrList -> _void) #:wrap (deallocator)) (define-pango pango_attr_list_new (_fun -> PangoAttrList) @@ -100,6 +113,8 @@ #:wrap (deallocator)) (define-pango pango_attr_underline_new (_fun _int -> PangoAttribute) #:wrap (allocator pango_attribute_destroy)) +(define-pango pango_attr_fallback_new (_fun _bool -> PangoAttribute) + #:wrap (allocator pango_attribute_destroy)) (define-pango pango_layout_set_attributes (_fun PangoLayout PangoAttrList -> _void)) diff --git a/src/mac/README.txt b/src/mac/README.txt index cea84190ce..d17519e022 100644 --- a/src/mac/README.txt +++ b/src/mac/README.txt @@ -1,5 +1,4 @@ -Information on building 3rd-party libraries needed for -Mac OS X GRacket. +Information on building 3rd-party libraries needed for Mac OS X GRacket. Get these packages (or newer, if compatible): pkg-config-0.23.tar.gz @@ -15,10 +14,18 @@ Patches: cairo/src/cairo-quartz-font.c:656: if (width < 1) width = 1; if (height < 1) height = 1; - glib/glib/gconvert.c:54: + glib/glib/gconvert.c:54: change to #if !(defined(__APPLE__) && defined(__LP64__)) && !defined(USE_LIBICONV_GNU) && defined (_LIBICONV_H) - pango/pango/modules.c:573: + pango/pango/modules.c:573: change to // read_modules (); + pango/modules/basic/basic-atsui.c:60: add + if (!glyph) { glyph = PANGO_GET_UNKNOWN_GLYPH(glyph); } + pango/pangocairo-atsuifont.c:141: add + metrics->underline_position = -metrics->underline_position; + pango_quantize_line_geometry (&metrics->underline_thickness, + &metrics->underline_position); + metrics->underline_position = -(metrics->underline_position + + metrics->underline_thickness); Configures (where is some temporary area): pkg-config: --prefix= @@ -38,3 +45,48 @@ Install: * do not include a trailing slash * double-check installed libraries to ensure that they do not have in their shared-library paths + +-------------------------------------------------- + +DESTDIR= +WORKDIR= +ARCHDIR= + +cd "$WORKDIR" +tar zxf "$ARCHDIR"pkg-config-0.23.tar.gz +tar zxf "$ARCHDIR"libpng-1.4.0.tar.gz +tar zxf "$ARCHDIR"pixman-0.17.14.tar.gz +tar zxf "$ARCHDIR"cairo-1.9.6.tar.gz +tar zxf "$ARCHDIR"gettext-0.17.tar.gz +tar zxf "$ARCHDIR"glib-2.22.4.tar.gz +tar zxf "$ARCHDIR"pango-1.28.0.tar.gz +cd pkg-config-0.23/ +./configure --prefix="$DESTDIR" +make +make install +cd ../libpng-1.4.0/ +./configure --prefix="$DESTDIR" +make +make install +cd .. +cd pixman-0.17.14/ +./configure --prefix="$DESTDIR" +make +make install +cd ../cairo-1.9.6/ +env PATH="$DESTDIR"/bin:"$PATH" ./configure --disable-xlib --disable-ft --disable-fc --prefix="$DESTDIR" +make +make install +cd ../gettext-0.17/ +./configure --prefix="$DESTDIR" +make +make install +cd ../glib +cd ../glib-2.22.4/ +env PATH="$DESTDIR"/bin:"$PATH" CFLAGS=-I"$DESTDIR"/include LDFLAGS=-L"$DESTDIR"/lib ./configure --prefix="$DESTDIR" +make +make install +cd ../pango-1.28.0/ +env PATH="$DESTDIR"/bin:"$PATH" ./configure --without-x --with-included-modules=yes --with-dynamic-modules=no --prefix="$DESTDIR" +make +make install diff --git a/src/mac/install-libs.rkt b/src/mac/install-libs.rkt index da6eb18bef..3e7583b7db 100644 --- a/src/mac/install-libs.rkt +++ b/src/mac/install-libs.rkt @@ -20,7 +20,7 @@ (define (fixup p p-new) (printf "Fixing ~s\n" p-new) - (system (format "install_name_tool -id ~a ~a" p-new (file-name-from-path p-new))) + (system (format "install_name_tool -id ~a ~a" (file-name-from-path p-new) p-new)) (for-each (lambda (s) (system (format "install_name_tool -change ~a @loader_path/~a ~a" (format "~a/~a.dylib" from s)