From ca64c25cf9f897c888531ef7ddf6b64260423d8e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 Oct 2010 14:50:58 -0600 Subject: [PATCH] cocoa: control fonts --- collects/mred/private/wx/cocoa/font.rkt | 48 +++++++++++++++++++++ collects/mred/private/wx/cocoa/item.rkt | 9 ++-- collects/mred/private/wx/cocoa/list-box.rkt | 13 +++++- collects/racket/draw/font-dir.rkt | 9 +++- collects/tests/gracket/item.rkt | 9 +++- 5 files changed, 79 insertions(+), 9 deletions(-) create mode 100644 collects/mred/private/wx/cocoa/font.rkt diff --git a/collects/mred/private/wx/cocoa/font.rkt b/collects/mred/private/wx/cocoa/font.rkt new file mode 100644 index 0000000000..7b438b0a90 --- /dev/null +++ b/collects/mred/private/wx/cocoa/font.rkt @@ -0,0 +1,48 @@ +#lang racket/base +(require racket/class + racket/draw + ffi/unsafe + ffi/unsafe/objc + "../../lock.rkt" + "const.rkt" + "utils.rkt" + "types.rkt") + +(provide font->NSFont) + +(import-class NSFont NSFontManager) + +(define NSItalicFontMask #x00000001) +(define NSBoldFontMask #x00000002) + +(define (font->NSFont f) + (let* ([weight (send f get-weight)] + [style (send f get-style)] + [name (or (send f get-face) + (send the-font-name-directory + get-screen-name + (send the-font-name-directory + find-family-default-font-id + (send f get-family)) + weight + style))]) + (atomically + (with-autorelease + (let ([f (tell NSFont + fontWithName: #:type _NSString name + size: #:type _CGFloat (send f get-point-size))]) + (if (and (eq? 'normal weight) + (eq? 'normal style)) + (begin + (retain f) + f) + (let ([fm (tell NSFontManager sharedFontManager)]) + (let ([f (tell fm + convertFont: f + toHaveTrait: #:type _int (bitwise-ior + (if (eq? weight 'bold) NSBoldFontMask 0) + (if (eq? style 'italic) NSItalicFontMask 0)))]) + (begin + (retain f) + f))))))))) + \ No newline at end of file diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index 571295bf04..6f3a04436c 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -2,10 +2,11 @@ (require scheme/class scheme/foreign ffi/objc - "../../syntax.rkt" + "../../syntax.rkt" "window.rkt" "const.rkt" - "types.rkt") + "types.rkt" + "font.rkt") (unsafe!) (objc-unsafe!) @@ -17,7 +18,9 @@ systemFontOfSize: #:type _CGFloat 13)) (define (install-control-font cocoa font) - (tellv cocoa setFont: sys-font)) + (if font + (tellv cocoa setFont: (font->NSFont font)) + (tellv cocoa setFont: sys-font))) (defclass item% window% (inherit get-cocoa) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index e25fb0f130..f5bffb686b 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -10,6 +10,7 @@ "types.rkt" "const.rkt" "window.rkt" + "font.rkt" "../common/event.rkt") (unsafe!) (objc-unsafe!) @@ -27,8 +28,12 @@ [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (let ([wx (->wx wxb)]) (tell - (tell (tell NSCell alloc) initTextCell: #:type _NSString - (if wx (send wx get-row row) "???")) + (let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString + (if wx (send wx get-row row) "???"))] + [font (send wx get-cell-font)]) + (when font + (tellv c setFont: font)) + c) autorelease))] [-a _void (doubleClicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] @@ -106,6 +111,10 @@ (def/public-unimplemented get-label-font) + (define cell-font (and font (font->NSFont font))) + (define/public (get-cell-font) + cell-font) + (define/public (get-selection) (tell #:type _NSInteger content-cocoa selectedRow)) (define/public (get-selections) diff --git a/collects/racket/draw/font-dir.rkt b/collects/racket/draw/font-dir.rkt index 69aa089778..5490ee7c88 100644 --- a/collects/racket/draw/font-dir.rkt +++ b/collects/racket/draw/font-dir.rkt @@ -49,9 +49,14 @@ (define/private (default-font s) (case s [(modern) "Monospace"] - [(roman) "Serif"] + [(roman) (case (system-type) + [(windows) "Times New Roman"] + [(macosx) "Times"] + [else "Serif"])] [(decorative swiss) "Helvetica"] - [(script) "Chancery"] + [(script) (case (system-type) + [(macosx) "Apple Chancery"] + [else "Chancery"])] [(symbol) "Symbol"] [else (case (system-type) [(windows) "Tahoma"] diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index e8bd6f9a00..4e32dd54bb 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -50,6 +50,10 @@ 20 'decorative 'normal 'bold #f)) +(define italic-font (send the-font-list find-or-create-font + 13 'roman + 'italic 'normal + #f)) (define ($ font) (or font normal-control-font)) (define (make-h&s cp f) @@ -2253,7 +2257,7 @@ (make-radio-box "Stretchiness" '("Normal" "All Stretchy") p1 void)) (define font-radio - (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big") + (make-radio-box "Label Font" '("Normal" "Small" "Tiny" "Big" "Italic") p1 void)) (define enabled-radio (make-radio-box "Initially" '("Enabled" "Disabled") @@ -2276,7 +2280,8 @@ (list-ref (list #f small-control-font tiny-control-font - special-font) + special-font + italic-font) (send font-radio get-selection)) (positive? (send enabled-radio get-selection)) (positive? (send selection-radio get-selection))