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

win32: control font

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-20 15:59:10 -06:00
parent ad9209f1e9
commit df94c04823
12 changed files with 101 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/mred/private/wx/win32/button.rkt
View File

@ -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))

4
collects/mred/private/wx/win32/check-box.rkt
View File

@ -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)))

3
collects/mred/private/wx/win32/choice.rkt
View File

@ -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))))

23
collects/mred/private/wx/win32/font.rkt Normal file
View File

@ -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))))

2
collects/mred/private/wx/win32/group-panel.rkt
View File

@ -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))))

2
collects/mred/private/wx/win32/message.rkt
View File

@ -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)))

2
collects/mred/private/wx/win32/procs.rkt
View File

@ -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))

7
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -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))))))))

3
collects/mred/private/wx/win32/slider.rkt
View File

@ -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)

3
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -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 +

63
collects/mred/private/wx/win32/window.rkt
View File

@ -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)]

25
collects/racket/draw/pango.rkt
View File

@ -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