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

.

Browse Source 
original commit: 200a1e4b21d946190a27bf171b8a6438baf3f221
This commit is contained in:
Matthew Flatt 2005-02-10 03:42:09 +00:00
parent 7c396dc378
commit db46b50542
11 changed files with 106 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/mred/mred-sig.ss
View File

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

4
collects/mred/mred.ss
View File

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

7
collects/mred/private/check.ss
View File

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

1
collects/mred/private/const.ss
View File

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

20
collects/mred/private/gdi.ss
View File

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

6
collects/mred/private/kernel.ss
View File

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

39
collects/mred/private/mritem.ss
View File

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

15
collects/mred/private/mrpanel.ss
View File

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

15
collects/mred/private/mrtextfield.ss
View File

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

32
collects/mred/private/wxitem.ss
View File

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

22
collects/mred/private/wxtextfield.ss
View File

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