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

order result of get-face-list

Browse Source 
svn: r5962

original commit: 7091496cd0d0a0d1c0b0eb4cf538ea6c86394bf5
This commit is contained in:
Matthew Flatt 2007-04-17 10:40:36 +00:00
parent a8a0cbd3e5
commit 64a34efa2a
3 changed files with 31 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/mred.ss
View File

@ -114,7 +114,6 @@
font%
font-list%
font-name-directory<%>
get-face-list
get-resource
get-the-editor-data-class-list
get-the-snip-class-list
@ -233,6 +232,7 @@
message+check-box
message-box/custom
message+check-box/custom
get-face-list
get-file
get-file-list
put-file

23
collects/mred/private/fontdialog.ss
View File

@ -39,28 +39,7 @@
(let ([s (send (send edit get-style-list) find-named-style "Standard")])
(send s set-delta (font->delta f))))))]
[p (make-object horizontal-pane% f)]
[face (make-object list-box% #f
(let ([l (wx:get-face-list)]
[ugly? (lambda (a)
(and (positive? (string-length a))
(not (or (char-alphabetic? (string-ref a 0))
(char-numeric? (string-ref a 0))
(char=? #\- (string-ref a 0))))))])
;; Sort space-starting first (for Xft), and
;; otherwise push names that start with an
;; ASCII non-letter/digit/hyphen to the end
(sort l (lambda (a b)
(let ([a-sp? (char=? #\space (string-ref a 0))]
[b-sp? (char=? #\space (string-ref b 0))]
[a-ugly? (ugly? a)]
[b-ugly? (ugly? b)])
(cond [(eq? a-sp? b-sp?)
(cond
[(eq? a-ugly? b-ugly?)
(string-locale-ci<? a b)]
[else b-ugly?])]
[else a-sp?])))))
p refresh-sample)]
[face (make-object list-box% #f (get-face-list) p refresh-sample)]
[p2 (make-object vertical-pane% p)]
[p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])]
[style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])])

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

@ -1,6 +1,7 @@
(module gdi mzscheme
(require (lib "class.ss")
(lib "class100.ss")
(lib "list.ss")
(prefix wx: "kernel.ss")
"lock.ss"
"check.ss"
@ -19,7 +20,8 @@
small-control-font
tiny-control-font
view-control-font
menu-control-font)
menu-control-font
get-face-list)
(define register-collecting-blit
(case-lambda
@ -191,6 +193,32 @@
(let-values ([(w h d a) (send dc get-text-extent string font)])
(values (inexact->exact w) (inexact->exact h)))])))
(define ugly?
(lambda (a)
(and (positive? (string-length a))
(not (or (char-alphabetic? (string-ref a 0))
(char-numeric? (string-ref a 0))
(char=? #\- (string-ref a 0)))))))
(define compare-face-names
(lambda (a b)
(let ([a-sp? (char=? #\space (string-ref a 0))]
[b-sp? (char=? #\space (string-ref b 0))]
[a-ugly? (ugly? a)]
[b-ugly? (ugly? b)])
(cond [(eq? a-sp? b-sp?)
(cond
[(eq? a-ugly? b-ugly?)
(string-locale-ci<? a b)]
[else b-ugly?])]
[else a-sp?]))))
(define get-face-list
(case-lambda
[() (get-face-list 'all)]
[(a) (sort (wx:get-face-list a) compare-face-names)]))
(define x-has-xft? 'unknown)
(define mswin-system #f)
(define mswin-default #f)