cocoa & gtk: color dialog

collects/mred/private/moredialogs.rkt

@@ -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)
+		   [repaint (lambda (ext)
-			      (let ([c (make-object wx:color% 
+			      (let ([c (get-current-color)])
-						    (send red get-value)
+                                (ext c)
-						    (send green get-value)
+                                (wx:fill-private-color (send canvas get-dc) c)))]
-						    (send blue get-value))])
+                   [update-and-repaint (lambda (s e)
-				(wx:fill-private-color (send canvas get-dc) c)))]
+                                         (repaint
-		   [make-color-slider (lambda (l) (make-object slider% l 0 255 p 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)])
+		   [bp (make-object horizontal-pane% f)]
-	    (when color
+                   [get-current-color
-	      (send red set-value (send color red))
+                    (lambda ()
-	      (send green set-value (send color green))
+                      (make-object wx:color% 
-	      (send blue set-value (send color blue)))
+                                   (send red get-value)
-            (ok-cancel
+                                   (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% 
+                 (get-current-color))))])))
-			      (send red get-value)
-			      (send green get-value)
-			      (send blue get-value)))))])))

collects/mred/private/wx/cocoa/colordialog.rkt

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

collects/mred/private/wx/cocoa/frame.rkt

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

collects/mred/private/wx/cocoa/platform.rkt

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

collects/mred/private/wx/cocoa/procs.rkt

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

collects/mred/private/wx/cocoa/slider.rkt

@@ -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)))
+      ;; heuristic: show up to tick marks:
-      (tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t)
+      (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)

collects/mred/private/wx/cocoa/window.rkt

@@ -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)
@@ -703,6 +706,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)))
 
 

collects/mred/private/wx/common/default-procs.rkt

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

collects/mred/private/wx/common/queue.rkt

@@ -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
+  ;; called in atomic mode in eventspace's thread
-  (let loop ([frames (get-top-level-windows)]) 
+  (let ([es (send win get-eventspace)])
-    (and (pair? frames)
+    (or (positive? (eventspace-external-modal es))
-         (let ([status (send (car frames) frame-relative-dialog-status win)])
+        (let loop ([frames (get-top-level-windows es)]) 
-           (case status
+          (and (pair? frames)
-             [(#f) (loop (cdr frames))]
+               (let ([status (send (car frames) frame-relative-dialog-status win)])
-             [(same) #f]
+                 (case status
-             [(other) #t])))))
+                   [(#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

collects/mred/private/wx/gtk/canvas.rkt

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

collects/mred/private/wx/gtk/colordialog.rkt

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

collects/mred/private/wx/gtk/filedialog.rkt

@@ -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 
+  (define dlg (as-gtk-window-allocation
-               message (and parent (send parent get-gtk))
+               (gtk_file_chooser_dialog_new 
-               (case type
+                message (and parent (send parent get-gtk))
-                 [(dir) 'select-folder]
+                (case type
-                 [(put) 'save]
+                  [(dir) 'select-folder]
-                 [else 'open])
+                  [(put) 'save]
-               "gtk-cancel" 'cancel
+                  [else 'open])
-               ;; no stock names for "Select"
+                "gtk-cancel" 'cancel
-               (case type
+                ;; no stock names for "Select"
-                 [(dir) "Choose"]
+                (case type
-                 [(put) "gtk-save"]
+                  [(dir) "Choose"]
-                 [(get) "gtk-open"]
+                  [(put) "gtk-save"]
-                 [(multi) "Choose"])
+                  [(get) "gtk-open"]
-               'accept
+                  [(multi) "Choose"])
-               #f))
+                '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
+  (define ans (and (eq? 'accept (show-dialog dlg
-                                      (lambda (v)
+                                             (lambda (v)
-                                        (or (not (= v -3))
+                                               (or (not (eq? v 'accept))
-                                            ;; FIXME: for get mode, probably should check file vs.
+                                                   ;; FIXME: for get mode, probably should check file vs.
-                                            ;;  directory name
+                                                   ;;  directory name
-                                            (not (eq? type 'put))
+                                                   (not (eq? type 'put))
-                                            (not (file-exists? (gtk_file_chooser_get_filename dlg)))
+                                                   (not (file-exists? (gtk_file_chooser_get_filename dlg)))
-                                            ;; FIXME: need to ask "replace the file? here
+                                                   ;; FIXME: need to ask "replace the file? here
-                                            #t))))
+                                                   #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)))

collects/mred/private/wx/gtk/platform.rkt

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

collects/mred/private/wx/gtk/procs.rkt

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

collects/mred/private/wx/gtk/stddialog.rkt

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

collects/mred/private/wx/gtk/style.rkt

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

collects/mred/private/wx/gtk/types.rkt

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

collects/mred/private/wx/platform.rkt

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

collects/mred/private/wx/win32/platform.rkt

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

collects/mred/private/wx/win32/procs.rkt

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