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

cocoa & gtk: color dialog

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-15 08:45:06 -06:00
parent c996185ea5
commit 18c99e52a5
20 changed files with 328 additions and 149 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/mred/private/moredialogs.rkt
View File

@ -284,32 +284,58 @@
(check-top-level-parent/false 'get-color-from-user parent)
(check-instance 'get-color-from-user wx:color% 'color% #t color)
(check-style 'get-color-from-user #f null style)
(if (not (eq? (system-type) 'unix))
(if (eq? (wx:color-from-user-platform-mode) 'dialog)
(wx:get-color-from-user message (and parent (mred->wx parent)) color)
(letrec ([ok? #f]
[f (make-object dialog% "Choose Color" parent)]
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
[canvas (make-object (class canvas%
(define/override (on-paint)
(repaint #f #f))
(repaint void))
(super-new [parent f])))]
[platform-p (and (string? (wx:color-from-user-platform-mode))
(new horizontal-panel%
[parent f]
[alignment '(right center)]))]
[p (make-object vertical-pane% f)]
[repaint (lambda (s e)
(let ([c (make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value))])
(wx:fill-private-color (send canvas get-dc) c)))]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))]
[repaint (lambda (ext)
(let ([c (get-current-color)])
(ext c)
(wx:fill-private-color (send canvas get-dc) c)))]
[update-and-repaint (lambda (s e)
(repaint
(lambda (c)
(when platform-p
(wx:get-color-from-user c)))))]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))]
[red (make-color-slider "Red:")]
[green (make-color-slider "Green:")]
[blue (make-color-slider "Blue:")]
[bp (make-object horizontal-pane% f)])
(when color
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue)))
(ok-cancel
[bp (make-object horizontal-pane% f)]
[get-current-color
(lambda ()
(make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value)))]
[install-color
(lambda (color)
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue))
(send canvas refresh))])
(when platform-p
(new button%
[parent platform-p]
[label (wx:color-from-user-platform-mode)]
[callback (lambda (b e) (wx:get-color-from-user 'show))])
(wx:get-color-from-user (or color
(make-object wx:color% 0 0 0)))
(send (mred->wx f) set-color-callback (lambda ()
(install-color
(wx:get-color-from-user 'get)))))
(when color (install-color color))
(ok-cancel
(lambda ()
(make-object button% "Cancel" bp (done #f)))
(lambda ()
@ -321,7 +347,4 @@
(send f center)
(send f show #t)
(and ok?
(make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value)))))])))
(get-current-color))))])))

43
collects/mred/private/wx/cocoa/colordialog.rkt Normal file
View File

@ -0,0 +1,43 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/draw/color
"../../lock.rkt"
"utils.rkt"
"types.rkt")
(provide get-color-from-user)
(import-class NSColorPanel
NSColor)
(define-cocoa NSDeviceRGBColorSpace _id)
(define (get-color-from-user mode)
(cond
[(eq? mode 'show)
(tellv (tell NSColorPanel sharedColorPanel)
orderFront: #f)]
[(eq? mode 'get)
(atomically
(let ([c (tell (tell (tell NSColorPanel sharedColorPanel) color)
colorUsingColorSpaceName: NSDeviceRGBColorSpace)]
[as-color (lambda (v)
(inexact->exact (floor (* 255.0 v))))])
(make-object color%
(as-color
(tell #:type _CGFloat c redComponent))
(as-color
(tell #:type _CGFloat c greenComponent))
(as-color
(tell #:type _CGFloat c blueComponent)))))]
[else
(let ([p (tell NSColorPanel sharedColorPanel)]
[color mode])
(atomically
(tellv p setColor: (tell NSColor
colorWithDeviceRed: #:type _CGFloat (/ (color-red color) 255.0)
green: #:type _CGFloat (/ (color-green color) 255.0)
blue: #:type _CGFloat (/ (color-blue color) 255.0)
alpha: #:type _CGFloat 1.0))))]))

9
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -496,7 +496,14 @@
(tellv cocoa miniaturize: cocoa))
(define/public (set-title s)
(tellv cocoa setTitle: #:type _NSString s))))
(tellv cocoa setTitle: #:type _NSString s))
(define color-callback void)
(define/public (set-color-callback cb)
(set! color-callback cb))
(define/override (on-color-change)
(queue-window-event this (lambda () (color-callback))))))
;; ----------------------------------------

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -79,6 +79,7 @@
play-sound
get-panel-background
get-font-from-user
color-from-user-platform-mode
get-color-from-user
special-option-key
special-control-key

26
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -10,19 +10,26 @@
"window.rkt"
"finfo.rkt" ; file-creator-and-type
"filedialog.rkt"
"colordialog.rkt"
"dc.rkt"
"printer-dc.rkt"
"../common/printer.rkt"
"menu-bar.rkt"
"agl.rkt"
"../../lock.rkt"
"../common/handlers.rkt")
"../common/handlers.rkt"
(except-in "../common/default-procs.rkt"
special-control-key
special-option-key
file-creator-and-type))
(provide
application-file-handler
application-quit-handler
application-about-handler
application-pref-handler
color-from-user-platform-mode
get-color-from-user
get-font-from-user
get-panel-background
@ -60,20 +67,20 @@
(import-class NSScreen NSCursor)
(define-unimplemented get-color-from-user)
(define-unimplemented get-font-from-user)
(define (get-panel-background) (make-object color% "gray"))
(define-unimplemented play-sound)
(define-unimplemented find-graphical-system-path)
(define-unimplemented send-event)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define (color-from-user-platform-mode) "Show Picker")
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
(define (unregister-collecting-blit canvas)
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [x #f]) #f)
(define-unimplemented send-event)
(define (begin-refresh-sequence) (void))
(define (end-refresh-sequence) (void))
(define run-printout (make-run-printout printer-dc%))
@ -82,9 +89,6 @@
(define (get-control-font-size) 13)
(define (get-control-font-size-in-pixels?) #f)
(define (cancel-quit) (void))
(define-unimplemented fill-private-color)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define (check-for-break) #f)
@ -110,7 +114,7 @@
(tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t))
(define (get-display-depth) 32)
(define-unimplemented is-color-display?)
(define (is-color-display?) #t)
(define (id-to-menu-item id) id)
(define (can-show-print-setup?) #t)

6
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -52,8 +52,10 @@
(tellv cocoa setMinValue: #:type _double* lo)
(tellv cocoa setMaxValue: #:type _double* hi)
(tellv cocoa setDoubleValue: #:type _double* val)
(tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo)))
(tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t)
;; heuristic: show up to tick marks:
(when ((- hi lo) . < . 64)
(tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo)))
(tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t))
(tellv cocoa setFrame: #:type _NSRect (make-NSRect
(make-NSPoint 0 0)
(make-NSSize (if vert? 24 32)

8
collects/mred/private/wx/cocoa/window.rkt
View File

@ -68,7 +68,10 @@
(and (super-tell resignFirstResponder)
(let ([wx (->wx wxb)])
(when wx (send wx is-responder wx #f))
#t))])
#t))]
[-a _void (changeColor: [_id sender])
(let ([wx (->wx wxb)])
(when wx (send wx on-color-change)))])
(import-class NSArray)
(import-protocol NSTextInput)
@ -702,6 +705,9 @@
(define/public (gets-focus?) #f)
(define/public (can-be-responder?) #t)
(define/public (on-color-change)
(send parent on-color-change))
(def/public-unimplemented centre)))

32
collects/mred/private/wx/common/default-procs.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket/base
(require racket/class
racket/draw/color)
(provide special-control-key
special-option-key
file-creator-and-type
get-panel-background
fill-private-color)
(define special-control-key? #f)
(define special-control-key
(case-lambda
[() special-control-key?]
[(on?) (set! special-control-key? (and on? #t))]))
(define special-option-key? #f)
(define special-option-key
(case-lambda
[() special-option-key?]
[(on?) (set! special-option-key? (and on? #t))]))
(define file-creator-and-type
(case-lambda
[(path cr ty) (void)]
[(path) (values #"????" #"????")]))
(define (get-panel-background)
(make-object color% "gray"))
(define (fill-private-color dc col)
(send dc set-background col)
(send dc clear))

31
collects/mred/private/wx/common/queue.rkt
View File

@ -31,6 +31,7 @@
eventspace-handler-thread
eventspace-wait-cursor-count
eventspace-extra-table
eventspace-adjust-external-modal!
queue-callback
middle-queue-key
@ -153,7 +154,8 @@
[shutdown? #:mutable]
done-sema
[wait-cursor-count #:mutable]
extra-table)
extra-table
[external-modal #:mutable])
#:property prop:evt (lambda (v)
(wrap-evt (eventspace-done-evt v)
(lambda (_) v))))
@ -318,7 +320,8 @@
#f
done-sema
0
(make-hash))]
(make-hash)
0)]
[cb-box (box #f)])
(parameterize ([current-cb-box cb-box])
(scheme_add_managed (current-custodian)
@ -437,14 +440,22 @@
(lambda (k v) k)))
(define (other-modal? win)
;; called in atmoic mode in eventspace's thread
(let loop ([frames (get-top-level-windows)])
(and (pair? frames)
(let ([status (send (car frames) frame-relative-dialog-status win)])
(case status
[(#f) (loop (cdr frames))]
[(same) #f]
[(other) #t])))))
;; called in atomic mode in eventspace's thread
(let ([es (send win get-eventspace)])
(or (positive? (eventspace-external-modal es))
(let loop ([frames (get-top-level-windows es)])
(and (pair? frames)
(let ([status (send (car frames) frame-relative-dialog-status win)])
(case status
[(#f) (loop (cdr frames))]
[(same) #f]
[(other) #t])))))))
(define (eventspace-adjust-external-modal! es amt)
(atomically
(set-eventspace-external-modal!
es
(+ (eventspace-external-modal es) amt))))
(define (queue-quit-event)
;; called in event-pump thread

5
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -98,11 +98,6 @@
(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void)
#:c-id g_object_set)
(define-cstruct _GdkColor ([pixel _uint32]
[red _uint16]
[green _uint16]
[blue _uint16]))
(define-gdk gdk_gc_unref (_fun _pointer -> _void)
#:wrap (deallocator))
(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer)

37
collects/mred/private/wx/gtk/colordialog.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/base
(require ffi/unsafe
racket/class
racket/draw/color
"types.rkt"
"utils.rkt"
"stddialog.rkt")
(provide get-color-from-user)
(define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget))
(define-gtk gtk_color_selection_dialog_get_color_selection (_fun _GtkWidget -> _GtkWidget))
(define-gtk gtk_color_selection_get_current_color (_fun _GtkWidget (c : (_ptr o _GdkColor)) -> _void -> c))
(define-gtk gtk_color_selection_set_current_color (_fun _GtkWidget _GdkColor-pointer -> _void))
(define (get-color-from-user message parent color)
(let ([d (as-gtk-window-allocation
(gtk_color_selection_dialog_new (or message "Choose Color")))]
[to-gdk (lambda (c) (arithmetic-shift c 8))])
(when color
(gtk_color_selection_set_current_color
(gtk_color_selection_dialog_get_color_selection d)
(make-GdkColor
0
(to-gdk (color-red color))
(to-gdk (color-green color))
(to-gdk (color-blue color)))))
(and (eq? (show-dialog d) 'ok)
(let ([c (gtk_color_selection_get_current_color
(gtk_color_selection_dialog_get_color_selection d))])
(make-object color%
(arithmetic-shift (GdkColor-red c) -8)
(arithmetic-shift (GdkColor-green c) -8)
(arithmetic-shift (GdkColor-blue c) -8))))))

89
collects/mred/private/wx/gtk/filedialog.rkt
View File

@ -8,6 +8,7 @@
"utils.rkt"
"widget.rkt"
"queue.rkt"
"stddialog.rkt"
"../common/handlers.rkt"
"../common/queue.rkt")
@ -18,20 +19,6 @@
(define _GtkFileChooserAction
(_enum (list 'open 'save 'select-folder 'create-folder)))
(define _GtkResponse
(_enum
'(none = -1
reject = -2
accept = -3
delete-event = -4
ok = -5
cancel = -6
close = -7
yes = -8
no = -9
apply = -10
help = -11)
_fixint))
;; FIXME: really there are varargs here, but we don't need them for
;; our purposes
(define-gtk gtk_file_chooser_dialog_new
@ -69,21 +56,22 @@
extension ;; always ignored
filters style parent)
(define type (car style)) ;; the rest of `style' is irrelevant on Gtk
(define dlg (gtk_file_chooser_dialog_new
message (and parent (send parent get-gtk))
(case type
[(dir) 'select-folder]
[(put) 'save]
[else 'open])
"gtk-cancel" 'cancel
;; no stock names for "Select"
(case type
[(dir) "Choose"]
[(put) "gtk-save"]
[(get) "gtk-open"]
[(multi) "Choose"])
'accept
#f))
(define dlg (as-gtk-window-allocation
(gtk_file_chooser_dialog_new
message (and parent (send parent get-gtk))
(case type
[(dir) 'select-folder]
[(put) 'save]
[else 'open])
"gtk-cancel" 'cancel
;; no stock names for "Select"
(case type
[(dir) "Choose"]
[(put) "gtk-save"]
[(get) "gtk-open"]
[(multi) "Choose"])
'accept
#f)))
(when (eq? 'multi type)
(gtk_file_chooser_set_select_multiple dlg #t))
(when filename
@ -97,15 +85,15 @@
(gtk_file_filter_set_name ff name)
(gtk_file_filter_add_pattern ff glob)
(gtk_file_chooser_add_filter dlg ff))]))
(define ans (and (= -3 (show-dialog dlg
(lambda (v)
(or (not (= v -3))
;; FIXME: for get mode, probably should check file vs.
;; directory name
(not (eq? type 'put))
(not (file-exists? (gtk_file_chooser_get_filename dlg)))
;; FIXME: need to ask "replace the file? here
#t))))
(define ans (and (eq? 'accept (show-dialog dlg
(lambda (v)
(or (not (eq? v 'accept))
;; FIXME: for get mode, probably should check file vs.
;; directory name
(not (eq? type 'put))
(not (file-exists? (gtk_file_chooser_get_filename dlg)))
;; FIXME: need to ask "replace the file? here
#t))))
(if (eq? type 'multi)
(gtk_file_chooser_get_filenames dlg)
(gtk_file_chooser_get_filename dlg))))
@ -113,28 +101,3 @@
ans)
(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean))
(define-signal-handler connect-response "response"
(_fun _GtkWidget _int _pointer -> _void)
(lambda (gtk id data)
(let* ([p (ptr-ref data _racket)]
[response-sema (car p)]
[response-box (cdr p)])
(set-box! response-box id)
(semaphore-post response-sema))))
(define (show-dialog dlg-gtk
[validate? (lambda (val) #t)])
(let* ([response-sema (make-semaphore)]
[response-box (box #f)]
[cell (malloc-immobile-cell (cons response-sema
response-box))])
(connect-response dlg-gtk cell)
(gtk_widget_show dlg-gtk)
(let loop ()
(yield response-sema)
(unless (validate? (unbox response-box))
(loop)))
(free-immobile-cell cell) ;; FIXME : don't leak
(gtk_widget_hide dlg-gtk)
(unbox response-box)))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -79,6 +79,7 @@
play-sound
get-panel-background
get-font-from-user
color-from-user-platform-mode
get-color-from-user
special-option-key
special-control-key

30
collects/mred/private/wx/gtk/procs.rkt
View File

@ -5,6 +5,7 @@
racket/class
racket/draw
"filedialog.rkt"
"colordialog.rkt"
"types.rkt"
"utils.rkt"
"style.rkt"
@ -14,12 +15,14 @@
"printer-dc.rkt"
"gl-context.rkt"
"../common/printer.rkt"
"../common/default-procs.rkt"
"../common/handlers.rkt")
(provide
special-control-key
special-option-key
get-color-from-user
color-from-user-platform-mode
get-font-from-user
get-panel-background
play-sound
@ -56,36 +59,29 @@
make-gl-bitmap
check-for-break)
(define-unimplemented special-control-key)
(define (special-option-key on?) (void))
(define-unimplemented get-color-from-user)
(define-unimplemented get-font-from-user)
(define (get-panel-background) (make-object color% "gray"))
(define-unimplemented play-sound)
(define-unimplemented find-graphical-system-path)
(define-unimplemented location->window)
(define-unimplemented send-event)
(define-unimplemented key-symbol-to-integer)
(define-unimplemented cancel-quit)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define (color-from-user-platform-mode) 'dialog)
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
(define (unregister-collecting-blit canvas)
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [mbar? #f]) #t)
(define-unimplemented location->window)
(define-unimplemented send-event)
(define file-creator-and-type
(case-lambda
[(path cr ty) (void)]
[(path) (values #"????" #"????")]))
(define run-printout (make-run-printout printer-dc%))
(define (get-double-click-time) 250)
(define-unimplemented key-symbol-to-integer)
(define (get-control-font-size) 10) ;; FIXME
(define (get-control-font-size-in-pixels?) #f) ;; FIXME
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int))
(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int))
@ -102,7 +98,7 @@
(define (hide-cursor) (void))
(define-unimplemented is-color-display?)
(define (is-color-display?) #t)
(define (id-to-menu-item i) i)
(define (can-show-print-setup?) #t)

54
collects/mred/private/wx/gtk/stddialog.rkt Normal file
View File

@ -0,0 +1,54 @@
#lang racket/base
(require ffi/unsafe
racket/class
"types.rkt"
"utils.rkt"
"widget.rkt"
"queue.rkt"
"../common/queue.rkt")
(provide show-dialog
_GtkResponse)
(define _GtkResponse
(_enum
'(none = -1
reject = -2
accept = -3
delete-event = -4
ok = -5
cancel = -6
close = -7
yes = -8
no = -9
apply = -10
help = -11)
_fixint))
(define-signal-handler connect-response "response"
(_fun _GtkWidget _GtkResponse _pointer -> _void)
(lambda (gtk id data)
(let* ([p (ptr-ref data _racket)]
[response-sema (car p)]
[response-box (cdr p)])
(set-box! response-box id)
(semaphore-post response-sema))))
(define (show-dialog dlg-gtk
[validate? (lambda (val) #t)])
(let* ([response-sema (make-semaphore)]
[response-box (box #f)]
[cell (malloc-immobile-cell (cons response-sema
response-box))]
[es (current-eventspace)])
(connect-response dlg-gtk cell)
(eventspace-adjust-external-modal! es 1)
(gtk_widget_show dlg-gtk)
(let loop ()
(yield response-sema)
(unless (validate? (unbox response-box))
(loop)))
(eventspace-adjust-external-modal! es -1)
(free-immobile-cell cell) ;; FIXME : don't leak
(gtk_widget_hide dlg-gtk)
(unbox response-box)))

6
collects/mred/private/wx/gtk/style.rkt
View File

@ -7,12 +7,6 @@
(provide get-selected-text-color
get-selected-background-color)
(define-cstruct _GdkColor
([pixel _uint32]
[red _uint16]
[green _uint16]
[blue _uint16]))
(define-cstruct _GTypeInstance
([class _pointer]))

9
collects/mred/private/wx/gtk/types.rkt
View File

@ -27,7 +27,9 @@
(struct-out GdkEventConfigure)
_GdkEventExpose _GdkEventExpose-pointer
(struct-out GdkEventExpose)
(struct-out GdkRectangle))
(struct-out GdkRectangle)
_GdkColor _GdkColor-pointer
(struct-out GdkColor))
(define _GType _long)
@ -131,3 +133,8 @@
[area _GdkRectangle]
[region _pointer]
[count _int]))
(define-cstruct _GdkColor ([pixel _uint32]
[red _uint16]
[green _uint16]
[blue _uint16]))

1
collects/mred/private/wx/platform.rkt
View File

@ -64,6 +64,7 @@
play-sound
get-panel-background
get-font-from-user
color-from-user-platform-mode
get-color-from-user
special-option-key
special-control-key

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -80,6 +80,7 @@
play-sound
get-panel-background
get-font-from-user
color-from-user-platform-mode
get-color-from-user
special-option-key
special-control-key

27
collects/mred/private/wx/win32/procs.rkt
View File

@ -11,6 +11,8 @@
"dc.rkt"
"printer-dc.rkt"
"../common/printer.rkt"
(except-in "../common/default-procs.rkt"
get-panel-background)
"filedialog.rkt"
racket/draw)
@ -18,6 +20,7 @@
special-control-key
special-option-key
get-color-from-user
color-from-user-platform-mode
get-font-from-user
get-panel-background
play-sound
@ -53,36 +56,34 @@
make-gl-bitmap
check-for-break)
(define-unimplemented special-control-key)
(define-unimplemented special-option-key)
(define-unimplemented get-color-from-user)
(define-unimplemented get-font-from-user)
(define-unimplemented play-sound)
(define-unimplemented find-graphical-system-path)
(define-unimplemented location->window)
(define-unimplemented send-event)
(define-unimplemented cancel-quit)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define-unimplemented get-color-from-user)
(define (color-from-user-platform-mode) #f)
(define (get-panel-background)
(let ([c (GetSysColor COLOR_BTNFACE)])
(make-object color% (GetRValue c) (GetGValue c) (GetBValue c))))
(define-unimplemented play-sound)
(define-unimplemented find-graphical-system-path)
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
(define (unregister-collecting-blit canvas)
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [? #f]) #t)
(define-unimplemented location->window)
(define-unimplemented send-event)
(define-unimplemented file-creator-and-type)
(define run-printout (make-run-printout printer-dc%))
(define (get-double-click-time) 500)
(define (get-control-font-size) (get-theme-font-size))
(define (get-control-font-size-in-pixels?) #t)
(define-unimplemented cancel-quit)
(define-unimplemented fill-private-color)
(define (flush-display) (void))
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define-user32 MessageBeep (_wfun _UINT -> _BOOL))
(define (bell)
@ -92,7 +93,7 @@
(define (get-display-depth) 32)
(define-unimplemented is-color-display?)
(define (is-color-display?) #t)
(define (can-show-print-setup?) #t)