diff --git a/collects/mred/private/wx/win32/button.rkt b/collects/mred/private/wx/win32/button.rkt index e3d86b84c9..f455c19284 100644 --- a/collects/mred/private/wx/win32/button.rkt +++ b/collects/mred/private/wx/win32/button.rkt @@ -64,13 +64,13 @@ (define/public (get-button-background) #xFFFFFF) - (define/public (auto-size-button label) + (define/public (auto-size-button font label) (cond [bitmap? - (auto-size label 0 0 4 4)] + (auto-size font label 0 0 4 4)] [else - (auto-size label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) - (auto-size-button label) + (auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)])) + (auto-size-button font label) (subclass-control (get-hwnd)) diff --git a/collects/mred/private/wx/win32/check-box.rkt b/collects/mred/private/wx/win32/check-box.rkt index 5eae81ad9b..675e4ae033 100644 --- a/collects/mred/private/wx/win32/check-box.rkt +++ b/collects/mred/private/wx/win32/check-box.rkt @@ -22,8 +22,8 @@ (define/override (get-button-background) (GetSysColor COLOR_BTNFACE)) - (define/override (auto-size-button label) - (auto-size label 0 0 20 0)) + (define/override (auto-size-button font label) + (auto-size font label 0 0 20 0)) (define/public (set-value v) (void (SendMessageW (get-hwnd) BM_SETCHECK (if v 1 0) 0))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index a9de92b2ea..a584a698d4 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -58,7 +58,8 @@ (set-control-font font) ;; setting the choice height somehow sets the ;; popup-menu size, not the control that you see - (auto-size (if (null? choices) (list "Choice") choices) + (auto-size font + (if (null? choices) (list "Choice") choices) 0 0 40 0 (lambda (w h) (set-size -11111 -11111 w (* h 8)))) diff --git a/collects/mred/private/wx/win32/font.rkt b/collects/mred/private/wx/win32/font.rkt new file mode 100644 index 0000000000..4017c64365 --- /dev/null +++ b/collects/mred/private/wx/win32/font.rkt @@ -0,0 +1,23 @@ +#lang racket +(require racket/class + racket/draw/local + racket/draw/pango) + +(provide font->hfont) + +(define display-font-map + (pango_win32_font_map_for_display)) + +(define display-context + (pango_font_map_create_context display-font-map)) + +(define font-cache (pango_win32_font_cache_new)) + +(define (font->hfont f) + (let* ([pfont (pango_font_map_load_font display-font-map + display-context + (send f get-pango))] + [logfont (pango_win32_font_logfont pfont)]) + (begin0 + (pango_win32_font_cache_load font-cache logfont) + (g_free logfont)))) diff --git a/collects/mred/private/wx/win32/group-panel.rkt b/collects/mred/private/wx/win32/group-panel.rkt index 3d7e7ff298..d77aabdac9 100644 --- a/collects/mred/private/wx/win32/group-panel.rkt +++ b/collects/mred/private/wx/win32/group-panel.rkt @@ -58,7 +58,7 @@ (define label-h 0) (set-control-font #f) - (auto-size label 0 0 0 0 + (auto-size #f label 0 0 0 0 (lambda (w h) (set! label-h h) (set-size -11111 -11111 (+ w 10) (+ h 10)))) diff --git a/collects/mred/private/wx/win32/message.rkt b/collects/mred/private/wx/win32/message.rkt index b85f46f8a8..1fd0598453 100644 --- a/collects/mred/private/wx/win32/message.rkt +++ b/collects/mred/private/wx/win32/message.rkt @@ -118,7 +118,7 @@ (if (symbol? label) (set-size -11111 -11111 32 32) - (auto-size label 0 0 0 0)) + (auto-size font label 0 0 0 0)) (define/override (get-setimage-message) STM_SETIMAGE))) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 9a4b70b46c..32153d9a20 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -85,7 +85,7 @@ (define run-printout (make-run-printout printer-dc%)) (define (get-double-click-time) 500) -(define (get-control-font-face) "Tahoma") +(define (get-control-font-face) (get-theme-font-face)) (define (get-control-font-size) (get-theme-font-size)) (define (get-control-font-size-in-pixels?) #t) (define (flush-display) (void)) diff --git a/collects/mred/private/wx/win32/radio-box.rkt b/collects/mred/private/wx/win32/radio-box.rkt index 4509455dd3..6b3b66dfe1 100644 --- a/collects/mred/private/wx/win32/radio-box.rkt +++ b/collects/mred/private/wx/win32/radio-box.rkt @@ -80,9 +80,10 @@ (ShowWindow radio-hwnd SW_SHOW) (set-control-font font radio-hwnd) (let-values ([(w1 h) - (auto-size label 0 0 20 4 (lambda (w h) - (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) - (values w h)))]) + (auto-size font label 0 0 20 4 + (lambda (w h) + (MoveWindow radio-hwnd 0 (+ y SEP) w h #t) + (values w h)))]) (cons radio-hwnd (loop (+ y SEP h) (max w1 w) (cdr labels)))))))) diff --git a/collects/mred/private/wx/win32/slider.rkt b/collects/mred/private/wx/win32/slider.rkt index 7ae2fedf87..2310b8c7af 100644 --- a/collects/mred/private/wx/win32/slider.rkt +++ b/collects/mred/private/wx/win32/slider.rkt @@ -112,7 +112,8 @@ (define value-h 0) (if panel-hwnd - (auto-size (list (format "~s" lo) + (auto-size font + (list (format "~s" lo) (format "~s" hi)) 0 0 0 0 (lambda (w h) (set! value-w w) diff --git a/collects/mred/private/wx/win32/tab-panel.rkt b/collects/mred/private/wx/win32/tab-panel.rkt index 9e01b2591c..03b4dea1ce 100644 --- a/collects/mred/private/wx/win32/tab-panel.rkt +++ b/collects/mred/private/wx/win32/tab-panel.rkt @@ -97,7 +97,8 @@ (define tab-height 0) (set-control-font #f) - (auto-size (if (null? choices) + (auto-size #f + (if (null? choices) '("Choice") choices) 0 0 0 0 #:combine-width + diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index e01fba1b8a..d3fd91eb76 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -16,7 +16,8 @@ "queue.rkt" "theme.rkt" "cursor.rkt" - "key.rkt") + "key.rkt" + "font.rkt") (provide window% queue-window-event @@ -306,41 +307,45 @@ (define/public (set-control-font font [hwnd hwnd]) (unless theme-hfont (set! theme-hfont (CreateFontIndirectW (get-theme-logfont)))) - (SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)) + (let ([hfont (if font + (font->hfont font) + theme-hfont)]) + (SendMessageW hwnd WM_SETFONT (cast hfont _HFONT _LPARAM) 0))) - (define/public (auto-size label min-w min-h dw dh + (define/public (auto-size font label min-w min-h dw dh [resize (lambda (w h) (set-size -11111 -11111 w h))] #:combine-width [combine-w max] #:combine-height [combine-h max] #:scale-w [scale-w 1] #:scale-h [scale-h 1]) - (unless measure-dc - (let* ([bm (make-object bitmap% 1 1)] - [dc (make-object bitmap-dc% bm)] - [font (make-object font% 8 'system)]) - (send dc set-font font) - (set! measure-dc dc))) - (let-values ([(w h d a) (let loop ([label label]) - (cond - [(null? label) (values 0 0 0 0)] - [(label . is-a? . bitmap%) - (values (send label get-width) - (send label get-height) - 0 - 0)] - [(pair? label) - (let-values ([(w1 h1 d1 a1) - (loop (car label))] - [(w2 h2 d2 a2) - (loop (cdr label))]) - (values (combine-w w1 w2) (combine-h h1 h2) - (combine-h d1 d1) (combine-h a1 a2)))] - [else - (send measure-dc get-text-extent label #f #t)]))] - [(->int) (lambda (v) (inexact->exact (floor v)))]) - (resize (->int (* scale-h (max (+ w dw) min-w))) - (->int (* scale-w (max (+ h dh) min-h)))))) + (atomically + (unless measure-dc + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)]) + (set! measure-dc dc))) + (send measure-dc set-font (or font + (make-object font% 8 'system))) + (let-values ([(w h d a) (let loop ([label label]) + (cond + [(null? label) (values 0 0 0 0)] + [(label . is-a? . bitmap%) + (values (send label get-width) + (send label get-height) + 0 + 0)] + [(pair? label) + (let-values ([(w1 h1 d1 a1) + (loop (car label))] + [(w2 h2 d2 a2) + (loop (cdr label))]) + (values (combine-w w1 w2) (combine-h h1 h2) + (combine-h d1 d1) (combine-h a1 a2)))] + [else + (send measure-dc get-text-extent label #f #t)]))] + [(->int) (lambda (v) (inexact->exact (floor v)))]) + (resize (->int (* scale-h (max (+ w dw) min-w))) + (->int (* scale-w (max (+ h dh) min-h))))))) (define/public (popup-menu m x y) (let ([gx (box x)] diff --git a/collects/racket/draw/pango.rkt b/collects/racket/draw/pango.rkt index 668f11a17e..178613171b 100644 --- a/collects/racket/draw/pango.rkt +++ b/collects/racket/draw/pango.rkt @@ -18,6 +18,12 @@ (ffi-lib "libgobject-2.0-0") (ffi-lib "libpango-1.0-0")])) +(define pangowin32-lib + (case (system-type) + [(windows) + (ffi-lib "libpangowin32-1.0-0")] + [else #f])) + (define pangocairo-lib (case (system-type) [(macosx) @@ -41,6 +47,8 @@ #:provide provide) (define-ffi-definer define-pangocairo pangocairo-lib #:provide provide) +(define-ffi-definer define-pangowin32 pangowin32-lib + #:provide provide) (define-ffi-definer define-glib glib-lib #:provide provide) @@ -109,6 +117,8 @@ (define-glib g_object_unref (_fun _pointer -> _void) #:wrap (deallocator)) +(define-glib g_free (_fun _pointer -> _void) + #:wrap (deallocator)) (define-pangocairo pango_cairo_font_map_get_default (_fun -> PangoFontMap)) ;; not an allocator (define-pangocairo pango_cairo_font_map_new (_fun -> PangoFontMap) @@ -212,6 +222,21 @@ (define-pango pango_font_description_set_size (_fun PangoFontDescription _int -> _void)) (define-pango pango_font_description_set_absolute_size (_fun PangoFontDescription _double* -> _void)) +(define _PangoWin32FontCache (_cpointer 'PangoWin32FontCache)) +(define _HFONT (_cpointer 'HFONT)) +(define _LOGFONT-pointer _pointer) +(define-pangowin32 pango_win32_font_map_for_display (_fun -> PangoFontMap) + #:make-fail make-not-available) +(define-pangowin32 pango_win32_font_logfont (_fun PangoFont -> _LOGFONT-pointer) + #:make-fail make-not-available + #:wrap (allocator g_free)) +(define-pangowin32 pango_win32_font_cache_unload (_fun _PangoWin32FontCache _HFONT -> _void) + #:make-fail make-not-available) +(define-pangowin32 pango_win32_font_cache_load (_fun _PangoWin32FontCache _LOGFONT-pointer -> _HFONT) + #:make-fail make-not-available) +(define-pangowin32 pango_win32_font_cache_new (_fun -> _PangoWin32FontCache) + #:make-fail make-not-available) + (define-enum 0 PANGO_STYLE_NORMAL