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

.

Browse Source 
original commit: 615882337b5b8687b03f868246f1c075b12393ae
This commit is contained in:
Matthew Flatt 2004-02-27 19:59:35 +00:00
parent 0b23678c19
commit 2757856cbf
4 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -39,6 +39,8 @@
control<%> control<%>
current-eventspace current-eventspace
current-eventspace-has-standard-menus? current-eventspace-has-standard-menus?
current-ps-afm-file-paths
current-ps-cmap-file-paths
current-ps-setup current-ps-setup
current-text-keymap-initializer current-text-keymap-initializer
cursor% cursor%

4
collects/mred/mred.ss
View File

@ -7895,7 +7895,9 @@
current-eventspace-has-menu-root? current-eventspace-has-menu-root?
eventspace-handler-thread eventspace-handler-thread
make-namespace-with-mred make-namespace-with-mred
file-creator-and-type) file-creator-and-type
current-ps-afm-file-paths
current-ps-cmap-file-paths)
) ;; end of module ) ;; end of module

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

@ -907,7 +907,7 @@
tell) tell)
(define-class editor-stream-in-bytes-base% editor-stream-in-base% #f) (define-class editor-stream-in-bytes-base% editor-stream-in-base% #f)
(define-class editor-stream-out-bytes-base% editor-stream-out-base% #f (define-class editor-stream-out-bytes-base% editor-stream-out-base% #f
get-string) get-bytes)
(define-class editor-stream-in% object% #f (define-class editor-stream-in% object% #f
ok? ok?
jump-to jump-to
@ -935,8 +935,8 @@
get-clipboard-bitmap get-clipboard-bitmap
set-clipboard-bitmap set-clipboard-bitmap
get-clipboard-data get-clipboard-data
get-clipboard-bytes get-clipboard-string
set-clipboard-bytes set-clipboard-string
set-clipboard-client) set-clipboard-client)
(define-function get-the-clipboard) (define-function get-the-clipboard)
(define-class clipboard-client% object% () (define-class clipboard-client% object% ()

27
collects/tests/mred/draw.ss
View File

@ -1,6 +1,15 @@
(require (lib "class100.ss")) (require (lib "class100.ss"))
(define manual-chinese? #f)
(when manual-chinese?
(send the-font-name-directory set-post-script-name
(send the-font-name-directory find-or-create-font-id "MOESung-Regular" 'default)
'normal
'normal
"MOESung-Regular"))
(define sys-path (define sys-path
(lambda (f) (lambda (f)
(build-path (collection-path "icons") f))) (build-path (collection-path "icons") f)))
@ -488,7 +497,8 @@
[wgt '(normal bold normal normal bold normal)] [wgt '(normal bold normal normal bold normal)]
[sze '(12 12 12 12 12 32)] [sze '(12 12 12 12 12 32)]
[x 244] [x 244]
[y 210]) [y 210]
[chinese? #t])
(unless (null? fam) (unless (null? fam)
(let ([fnt (make-object font% (car sze) (car fam) (car stl) (car wgt))] (let ([fnt (make-object font% (car sze) (car fam) (car stl) (car wgt))]
[s "AgMh"]) [s "AgMh"])
@ -498,7 +508,20 @@
(let-values ([(w h d a) (send dc get-text-extent s fnt)]) (let-values ([(w h d a) (send dc get-text-extent s fnt)])
(send dc draw-rectangle x y w h) (send dc draw-rectangle x y w h)
(send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d))) (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d)))
(loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h)))))) (when chinese?
(let ([s "\u7238"]
[x (+ x (* 1.5 w))]
[cfnt (if (and (dc . is-a? . post-script-dc%)
manual-chinese?)
(make-object font% 12 "MOESung-Regular" 'default)
fnt)])
(send dc set-font cfnt)
(send dc draw-text s x y)
(send dc set-font fnt)
(let-values ([(w h d a) (send dc get-text-extent s cfnt)])
(send dc draw-rectangle x y w h)
(send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d))))))
(loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h) #f)))))
(send dc set-pen save-pen))) (send dc set-pen save-pen)))
; Bitmap copying: ; Bitmap copying: