diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index daeb6129..fddafc46 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -132,6 +132,7 @@ mouse-event% ;; mred@ mult-color<%> + normal-control-font open-input-graphical-file open-input-text-editor pane% @@ -161,6 +162,7 @@ separator-menu-item% sleep/yield slider% + small-control-font snip% snip-admin% snip-class% @@ -187,10 +189,12 @@ the-style-list the-x-selection-clipboard timer% + tiny-control-font top-level-window<%> unregister-collecting-blit vertical-pane% vertical-panel% + view-control-font window<%> write-editor-global-footer write-editor-global-header diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index f45649ef..56eb642a 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -267,6 +267,10 @@ the-pen-list the-font-list the-style-list + normal-control-font + small-control-font + tiny-control-font + view-control-font timer% readable-snip<%> open-input-text-editor diff --git a/collects/mred/private/check.ss b/collects/mred/private/check.ss index 006f0e32..cb6d51a8 100644 --- a/collects/mred/private/check.ss +++ b/collects/mred/private/check.ss @@ -1,7 +1,8 @@ (module check mzscheme (require (lib "class.ss") (prefix wx: "kernel.ss") - "wx.ss") + "wx.ss" + "const.ss") (provide (all-defined)) (define (who->name who) @@ -138,6 +139,10 @@ (memq label '(app caution stop))) (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label))) + (define (check-font who f) + (unless (or (eq? f no-val) (f . is-a? . wx:font%)) + (raise-type-error (who->name who) "font% object" f))) + (define (check-style who reqd other-allowed style) (unless (and (list? style) (andmap symbol? style)) (raise-type-error (who->name who) "list of style symbols" style)) diff --git a/collects/mred/private/const.ss b/collects/mred/private/const.ss index ad62f08e..5fd7912a 100644 --- a/collects/mred/private/const.ss +++ b/collects/mred/private/const.ss @@ -31,6 +31,7 @@ ;; indicates init arg not supplied (define no-val (gensym)) + (define (no-val->#f v) (if (eq? v no-val) #f v)) (define ibeam (make-object wx:cursor% 'ibeam)) (define arrow-cursor (make-object wx:cursor% 'arrow)) diff --git a/collects/mred/private/gdi.ss b/collects/mred/private/gdi.ss index 9677d365..63211a22 100644 --- a/collects/mred/private/gdi.ss +++ b/collects/mred/private/gdi.ss @@ -14,7 +14,11 @@ post-script-dc% printer-dc% get-window-text-extent - get-family-builtin-face) + get-family-builtin-face + normal-control-font + view-control-font + small-control-font + tiny-control-font) (define register-collecting-blit (case-lambda @@ -143,4 +147,16 @@ [(modern) "Courier New"] [(swiss) "Helvetica"] [(script) "Apple Chancery"] - [(symbol) "Symbol"])]))) + [(symbol) "Symbol"])])) + + (define small-delta (case (system-type) + [(windows) 0] + [(macosx) 2] + [else 1])) + + (define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system)) + (define view-control-font (if (eq? 'macosx (system-type)) + (make-object wx:font% 12 'system) + (make-object wx:font% (wx:get-control-font-size) 'system))) + (define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system)) + (define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) 2 small-delta) 'system))) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 3ef5ba12..73ed7084 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -151,6 +151,7 @@ get-label command) (define-class message% item% #f + get-font set-label on-drop-file pre-on-event @@ -640,6 +641,7 @@ set-screen-name get-post-script-name get-screen-name) + (define-function get-control-font-size) (define-function get-the-font-name-directory) (define-function get-the-font-list) (define-function get-the-pen-list) @@ -1141,10 +1143,6 @@ copy cut) (define-class panel% window% #f - get-label-font - set-label-font - get-control-font - set-control-font get-label-position set-label-position on-char diff --git a/collects/mred/private/mritem.ss b/collects/mred/private/mritem.ss index 08a357ab..639a078b 100644 --- a/collects/mred/private/mritem.ss +++ b/collects/mred/private/mritem.ss @@ -42,12 +42,15 @@ (define-local-member-name hidden-child? label-checker) (define-keywords control%-keywords + [font no-val] window%-keywords subarea%-keywords area%-keywords) (define basic-control% - (class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor) + (class100* (make-window% #f (make-subarea% area%)) (control<%>) (mk-wx mismatches lbl parent cb cursor + ;; for keyword use + [font no-val]) (rename [super-set-label set-label]) (private-field [label lbl][callback cb]) (override @@ -97,12 +100,13 @@ (let ([cwho '(constructor message)]) (check-label-string/bitmap/iconsym cwho label) (check-container-parent cwho parent) - (check-style cwho #f '(deleted) style)) + (check-style cwho #f '(deleted) style) + (check-font cwho font)) (as-entry (lambda () (super-init (lambda () (make-object wx-message% this this (mred->wx-container parent) - label -1 -1 style)) + label -1 -1 style (no-val->#f font))) (lambda () (let ([cwho '(constructor message)]) (check-container-ready cwho parent))) @@ -117,12 +121,13 @@ (check-label-string-or-bitmap cwho label) (check-container-parent cwho parent) (check-callback cwho callback) - (check-style cwho #f '(border deleted) style)) + (check-style cwho #f '(border deleted) style) + (check-font cwho font)) (as-entry (lambda () (super-init (lambda () (make-object wx-button% this this (mred->wx-container parent) (wrap-callback callback) - label -1 -1 -1 -1 style)) + label -1 -1 -1 -1 style (no-val->#f font))) (lambda () (let ([cwho '(constructor button)]) (check-container-ready cwho parent))) @@ -135,7 +140,8 @@ (check-label-string-or-bitmap cwho label) (check-container-parent cwho parent) (check-callback cwho callback) - (check-style cwho #f '(deleted) style))) + (check-style cwho #f '(deleted) style) + (check-font cwho font))) (override [label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method (private-field @@ -149,7 +155,7 @@ (super-init (lambda () (set! wx (make-object wx-check-box% this this (mred->wx-container parent) (wrap-callback callback) - label -1 -1 -1 -1 style)) + label -1 -1 -1 -1 style (no-val->#f font))) wx) (lambda () (let ([cwho '(constructor check-box)]) @@ -213,7 +219,7 @@ (super-init (lambda () (set! wx (make-object wx-radio-box% this this (mred->wx-container parent) (wrap-callback callback) - label -1 -1 -1 -1 chcs 0 style)) + label -1 -1 -1 -1 chcs 0 style (no-val->#f font))) wx) (lambda () (let ([cwho '(constructor radio-box)]) @@ -240,7 +246,8 @@ (check-container-parent cwho parent) (check-callback cwho callback) (check-slider-integer cwho init-value) - (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style))) + (check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style) + (check-font cwho font))) (private-field [wx #f]) (public @@ -260,7 +267,7 @@ (super-init (lambda () (set! wx (make-object wx-slider% this this (mred->wx-container parent) (wrap-callback callback) - label init-value minv maxv style)) + label init-value minv maxv style (no-val->#f font))) wx) (lambda () (let ([cwho '(constructor slider)]) @@ -300,7 +307,7 @@ (super-init (lambda () (set! wx (make-object wx-gauge% this this (mred->wx-container parent) - label range style)) + label range style (no-val->#f font))) wx) (lambda () (let ([cwho '(constructor gauge)]) @@ -419,10 +426,11 @@ (let ([cwho '(constructor choice)]) (check-list-control-args cwho label choices parent callback) (check-style cwho #f '(vertical-label horizontal-label deleted) style) - (check-non-negative-integer cwho selection)) + (check-non-negative-integer cwho selection) + (check-font cwho font)) (super-init (lambda () (make-object wx-choice% this this (mred->wx-container parent) (wrap-callback callback) - label -1 -1 -1 -1 choices style)) + label -1 -1 -1 -1 choices style (no-val->#f font))) (lambda () (let ([cwho '(constructor choice)]) (check-container-ready cwho parent) @@ -441,7 +449,8 @@ (let ([cwho '(constructor list-box)]) (check-list-control-args cwho label choices parent callback) (check-style cwho '(single multiple extended) '(vertical-label horizontal-label deleted) style) - (check-non-negative-integer/false cwho selection))) + (check-non-negative-integer/false cwho selection) + (check-font cwho font))) (rename [super-append append]) (override [append (entry-point @@ -508,7 +517,7 @@ (set! wx (make-object wx-list-box% this this (mred->wx-container parent) (wrap-callback callback) label kind - -1 -1 -1 -1 choices style))) + -1 -1 -1 -1 choices style (no-val->#f font)))) wx) (lambda () (let ([cwho '(constructor list-box)]) diff --git a/collects/mred/private/mrpanel.ss b/collects/mred/private/mrpanel.ss index 701f4f27..95965591 100644 --- a/collects/mred/private/mrpanel.ss +++ b/collects/mred/private/mrpanel.ss @@ -101,14 +101,15 @@ (define tab-panel% (class100*/kw vertical-panel% () - [(choices parent callback [style null]) panel%-keywords] + [(choices parent callback [style null] [font no-val]) panel%-keywords] (sequence (let ([cwho '(constructor tab-panel)]) (unless (and (list? choices) (andmap label-string? choices)) (raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)) (check-callback cwho callback) (check-container-parent cwho parent) - (check-style cwho #f '(deleted no-border) style)) + (check-style cwho #f '(deleted no-border) style) + (check-font cwho font)) (super-init parent (if (memq 'deleted style) '(deleted) null))) @@ -117,7 +118,8 @@ [tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e)) (if (memq 'no-border style) null - '(border)))]) + '(border)) + font)]) (sequence (send (mred->wx this) set-first-child-is-hidden)) @@ -182,12 +184,13 @@ (define group-box-panel% (class100*/kw vertical-panel% () - [(label parent [style null]) panel%-keywords] + [(label parent [style null] [font no-val]) panel%-keywords] (sequence (let ([cwho '(constructor group-box-panel)]) (check-label-string cwho label) (check-container-parent cwho parent) - (check-style cwho #f '(deleted) style)) + (check-style cwho #f '(deleted) style) + (check-font cwho font)) ;; Technically a bad way to change margin defaults, since it's ;; implemented with an update after creation: @@ -199,7 +202,7 @@ null))) (private-field - [gbox (make-object group-box% label this null)] + [gbox (make-object group-box% label this null font)] [lbl label]) (sequence (send (mred->wx this) set-first-child-is-hidden)) diff --git a/collects/mred/private/mrtextfield.ss b/collects/mred/private/mrtextfield.ss index fa1ed892..dffcef8d 100644 --- a/collects/mred/private/mrtextfield.ss +++ b/collects/mred/private/mrtextfield.ss @@ -26,7 +26,8 @@ parent callback init-value - style req-styles) + style req-styles + font) (check-label-string/false cwho label) (when choices? (unless (and (list? choices) (andmap label-string? choices)) @@ -39,7 +40,8 @@ (append (if choices? null '(hscroll password)) '(vertical-label horizontal-label deleted)) - (remq combo-flag style))) + (remq combo-flag style)) + (check-font cwho font)) (define text-field% (class100*/kw basic-control% () @@ -50,7 +52,8 @@ label #f #f parent callback init-value - style '(single multiple))) + style '(single multiple) + font)) (private-field [wx #f]) (public @@ -73,7 +76,8 @@ label init-value (if (memq combo-flag style) (cons 'combo (remq combo-flag style)) - style))) + style) + (no-val->#f font))) wx) (lambda () (let ([cwho '(constructor text-field)]) @@ -90,7 +94,8 @@ label #f choices parent callback init-value - style #f)) + style #f + font)) (public [on-popup (lambda (e) (let-values ([(w h) (get-size)] diff --git a/collects/mred/private/wxitem.ss b/collects/mred/private/wxitem.ss index 3c03f524..3d2f7be1 100644 --- a/collects/mred/private/wxitem.ss +++ b/collects/mred/private/wxitem.ss @@ -218,7 +218,7 @@ #f #f)) (define wx-button% (make-window-glue% - (class100 (make-simple-control% wx:button%) (parent cb label x y w h style) + (class100 (make-simple-control% wx:button%) (parent cb label x y w h style font) (inherit command) (private-field [border? (memq 'border style)]) (public [has-border? (lambda () border?)]) @@ -227,8 +227,8 @@ (as-exit (lambda () (command (make-object wx:control-event% 'button)))))]) - (sequence (super-init style parent cb label x y w h style))))) - (define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style) + (sequence (super-init style parent cb label x y w h style font))))) + (define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style font) (inherit set-value get-value command) (override [char-to (lambda () @@ -236,24 +236,24 @@ (lambda () (set-value (not (get-value))) (command (make-object wx:control-event% 'check-box)))))]) - (sequence (super-init mred proxy style parent cb label x y w h style)))) - (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style) + (sequence (super-init mred proxy style parent cb label x y w h style font)))) + (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) (override [handles-key-code (lambda (x alpha? meta?) (or (memq x '(up down)) (and alpha? (not meta?))))]) - (sequence (super-init mred proxy style parent cb label x y w h choices style)))) - (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style) + (sequence (super-init mred proxy style parent cb label x y w h choices style font)))) + (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font) (override [gets-focus? (lambda () #f)]) - (sequence (super-init mred proxy style parent label x y style)))) + (sequence (super-init mred proxy style parent label x y style font)))) (define wx-gauge% (make-window-glue% (class100 (make-control% wx:gauge% const-default-x-margin const-default-y-margin #f #f) - (parent label range style) + (parent label range style font) (inherit get-client-size get-width get-height set-size stretchable-in-x stretchable-in-y set-min-height set-min-width get-parent) @@ -262,7 +262,7 @@ ;; # pixels per unit of value. [pixels-per-value 1]) (sequence - (super-init style parent label range -1 -1 -1 -1 style) + (super-init style parent label range -1 -1 -1 -1 style font) (let-values ([(client-width client-height) (get-two-int-values (lambda (a b) (get-client-size a b)))]) @@ -303,7 +303,7 @@ (make-window-glue% (class100 (make-control% wx:list-box% const-default-x-margin const-default-y-margin - #t #t) (parent cb label kind x y w h choices style) + #t #t) (parent cb label kind x y w h choices style font) (inherit get-first-item set-first-visible-item) (private @@ -328,11 +328,11 @@ [(wheel-up) (scroll -1) #t] [(wheel-down) (scroll 1) #t] [else #f])))]) - (sequence (super-init style parent cb label kind x y w h choices style))))) + (sequence (super-init style parent cb label kind x y w h choices style font))))) (define wx-radio-box% (make-window-glue% - (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style) + (class100 (make-simple-control% wx:radio-box%) (parent cb label x y w h choices major style font) (inherit number orig-enable set-selection command) (override [enable @@ -356,7 +356,7 @@ (set-selection i) (command (make-object wx:control-event% 'radio-box)))))]) - (sequence (super-init style parent cb label x y w h choices major style)) + (sequence (super-init style parent cb label x y w h choices major style font)) (private-field [enable-vector (make-vector (number) #t)])))) @@ -365,7 +365,7 @@ (class100 (make-control% wx:slider% const-default-x-margin const-default-y-margin #f #f) - (parent func label value min-val max-val style) + (parent func label value min-val max-val style font) (inherit set-min-width set-min-height stretchable-in-x stretchable-in-y get-client-size get-width get-height get-parent) (private-field @@ -376,7 +376,7 @@ ;; which looks bad. (sequence - (super-init style parent func label value min-val max-val -1 -1 -1 style) + (super-init style parent func label value min-val max-val -1 -1 -1 style font) (let-values ([(client-w client-h) (get-two-int-values (lambda (a b) (get-client-size a b)))]) diff --git a/collects/mred/private/wxtextfield.ss b/collects/mred/private/wxtextfield.ss index b9cb14a6..74a752ab 100644 --- a/collects/mred/private/wxtextfield.ss +++ b/collects/mred/private/wxtextfield.ss @@ -6,6 +6,7 @@ "const.ss" "check.ss" "helper.ss" + "gdi.ss" "wx.ss" "wxwindow.ss" "wxitem.ss" @@ -67,11 +68,12 @@ (super-init mred proxy parent -1 -1 100 30 #f style 100 #f)))) (define wx-text-field% - (class100 wx-horizontal-panel% (mred proxy parent fun label value style) + (class100 wx-horizontal-panel% (mred proxy parent fun label value style _font) ;; Make text field first because we'll have to exit ;; for keymap initializer (private-field [func fun] + [font (or _font normal-control-font)] [without-callback #f] [callback-ready #f] [e (make-object text-field-text% @@ -88,7 +90,7 @@ (as-exit (lambda () ((current-text-keymap-initializer) (send e get-keymap))))) - (inherit alignment stretchable-in-y get-control-font area-parent + (inherit alignment stretchable-in-y area-parent get-min-size set-min-width set-min-height) (rename [super-place-children place-children]) (public @@ -146,7 +148,7 @@ (unless multi? (stretchable-in-y #f))) (private-field [l (and label - (make-object wx-message% #f proxy p label -1 -1 null))] + (make-object wx-message% #f proxy p label -1 -1 null font))] [c (make-object wx-text-editor-canvas% #f proxy this p (append '(control-border) @@ -166,7 +168,7 @@ (send e set-line-spacing 0) (send e set-paste-text-only #t) (send e auto-wrap (and multi? (not (memq 'hscroll style)))) - (let ([f (get-control-font)] + (let ([f font] [s (send (send e get-style-list) find-named-style "Standard")]) (send s set-delta (let ([d (font->delta f)]) (if (memq 'password style) @@ -188,28 +190,28 @@ [hbox (box 0)] [ybox (box 0)] [abox (box 0)]) - ; To bottom of first line + ;; To bottom of first line (send (send e get-admin) get-dc #f ybox) (set! dy (+ (abs (unbox ybox)) (send e line-location 0 #f))) - ; Add diff for client size + ;; Add diff for client size (send c get-client-size wbox hbox) (let ([d (- (send c get-height) (unbox hbox))]) (set! dy (+ dy (quotient d 2)))) - ; Subtract descent of canvas-drawn text + ;; Subtract descent of canvas-drawn text (let ([font (send (send (send e get-style-list) find-named-style "Standard") get-font)]) (send c get-text-extent "hi" wbox hbox ybox #f font) (set! dy (- dy (unbox ybox)))) - ; Subtract ascent of label + ;; Subtract ascent of label (send l get-text-extent "hi" wbox hbox ybox abox) (set! dy (- dy (- (unbox hbox) (unbox ybox)))) - ; Subtract space above label + ;; Subtract space above label (set! dy (- dy (quotient (- (send l get-height) (unbox hbox)) 2))) - ; Exact + ;; Exact (set! dy (inexact->exact dy)))) (when value