win32: misc repairs

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

@@ -47,8 +47,6 @@
  is-color-display?
  file-selector
  id-to-menu-item
- get-the-x-selection
- get-the-clipboard
  show-print-setup
  can-show-print-setup?
  get-highlight-background-color
@@ -108,8 +106,6 @@
 (define (get-display-depth) 32)
 (define-unimplemented is-color-display?)
 (define (id-to-menu-item id) id)
-(define-unimplemented get-the-x-selection)
-(define-unimplemented get-the-clipboard)
 (define-unimplemented show-print-setup)
 (define (can-show-print-setup?) #t)
 

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

@@ -45,8 +45,6 @@
  is-color-display?
  file-selector
  id-to-menu-item
- get-the-x-selection
- get-the-clipboard
  show-print-setup
  can-show-print-setup?
  get-highlight-background-color
@@ -103,8 +101,6 @@
 (define-unimplemented is-color-display?)
 
 (define (id-to-menu-item i) i)
-(define-unimplemented get-the-x-selection)
-(define-unimplemented get-the-clipboard)
 (define-unimplemented show-print-setup)
 (define (can-show-print-setup?) #f)
 

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

@@ -54,7 +54,7 @@
 
     (when bitmap?
       (SendMessageW (get-hwnd) BM_SETIMAGE IMAGE_BITMAP 
-                    (cast (bitmap->hbitmap label) _HBITMAP _LPARAM)))
+                    (cast (bitmap->hbitmap label #:bg #xFFFFFF) _HBITMAP _LPARAM)))
 
     (set-control-font font)
 

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

@@ -278,6 +278,10 @@
                                          (send col green)
                                          (send col blue)))))
 
+     (define wants-focus? (not (memq 'no-focus style)))
+     (define/override (can-accept-focus?)
+       wants-focus?)
+
      (define h-scroll-visible? hscroll?)
      (define v-scroll-visible? vscroll?)
      (define/public (show-scrollbars h? v?)

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

@@ -13,6 +13,7 @@
          ffi/unsafe/alloc)
 
 (provide dc%
+         win32-bitmap%
          do-backing-flush
          request-flush-delay
          cancel-flush-delay)
@@ -23,14 +24,21 @@
     (super-make-object (make-alternate-bitmap-kind w h))
 
     (define s
-      (if (not hwnd)
+      (let ([s
-	  (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
+             (if (not hwnd)
-	  (atomically
+                 (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
-	   (let ([hdc (GetDC hwnd)])
+                 (atomically
-	     (begin0
+                  (let ([hdc (GetDC hwnd)])
-	      (cairo_win32_surface_create_with_ddb hdc
+                    (begin0
-						   CAIRO_FORMAT_RGB24 w h)
+                     (cairo_win32_surface_create_with_ddb hdc
-	      (ReleaseDC hwnd hdc))))))
+                                                          CAIRO_FORMAT_RGB24 w h)
+                     (ReleaseDC hwnd hdc)))))])
+        ;; initialize bitmap to white:
+        (let ([cr (cairo_create s)])
+          (cairo_set_source_rgba cr 1.0 1.0 1.0 1.0)
+          (cairo_paint cr)
+          (cairo_destroy cr))
+        s))
 
     (define/override (ok?) #t)
     (define/override (is-color?) #t)

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

@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/class
+         racket/draw
          (only-in racket/list last)
          ffi/unsafe
 	 "../../syntax.rkt"
@@ -12,6 +13,7 @@
          "theme.rkt"
 	 "window.rkt"
          "wndclass.rkt"
+         "hbitmap.rkt"
          "cursor.rkt")
 
 (provide frame%
@@ -37,6 +39,14 @@
                              [ptMinTrackSize _POINT]
                              [ptMaxTrackSize _POINT]))
 
+(define-cstruct _ICONINFO ([fIcon _BOOL]
+                           [xHotspot _DWORD]
+                           [yHotspot _DWORD]
+                           [hbmMask _HBITMAP]
+                           [hbmColor _HBITMAP]))
+(define-user32 CreateIconIndirect (_wfun _ICONINFO-pointer -> (r : _HICON)
+                                         -> (or r (failed 'CreateIconIndirect))))
+
 (define SPI_GETWORKAREA            #x0030)
 
 (define (display-size xb yb ?)
@@ -119,7 +129,7 @@
 
   (super-new [parent #f]
 	     [hwnd (create-frame parent label w h style)]
-	     [style (cons 'invisible style)])
+	     [style (cons 'deleted style)])
 
   (define hwnd (get-hwnd))
   (SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA)
@@ -148,6 +158,9 @@
                                SW_SHOWMAXIMIZED
                                SW_SHOW)))
 
+  (define/public (destroy)
+    (direct-show #f))
+
   (define/private (stdret f d)
     (if (is-dialog?) d f))
 
@@ -366,7 +379,22 @@
   (define/override (is-frame?) #t)
 
   (define/public (set-icon bm mask [mode 'both])
-    (void))
+    (let ([hicon (CreateIconIndirect
+                  (make-ICONINFO
+                   #t 0 0
+                   (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))]
+                          [dc (make-object bitmap-dc% bm)])
+                     (send dc set-brush "black" 'solid)
+                     (send dc draw-rectangle 0 0 (send bm get-width) (send bm get-height))
+                     (send dc set-bitmap #f)
+                     (bitmap->hbitmap bm #:b&w? #t))
+                   (bitmap->hbitmap bm #:mask mask)))])
+      (when (or (eq? mode 'small)
+                (eq? mode 'both))
+        (SendMessageW hwnd WM_SETICON 0 (cast hicon _HICON _LPARAM)))
+      (when (or (eq? mode 'big)
+                (eq? mode 'both))
+        (SendMessageW hwnd WM_SETICON 1 (cast hicon _HICON _LPARAM)))))
 
   (def/public-unimplemented iconize)
   (define/public (set-title s)

collects/mred/private/wx/win32/group-panel.rkt

@@ -49,6 +49,7 @@
     (super-new [callback void]
                [parent parent]
                [hwnd hwnd]
+               [extra-hwnds (list client-hwnd)]
                [style style])
 
     (define/override (get-client-hwnd)

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

@@ -11,37 +11,52 @@
 (provide bitmap->hbitmap)
 
 (define-gdi32 CreateCompatibleBitmap (_wfun _HDC _int _int -> _HBITMAP))
+(define-gdi32 CreateBitmap (_wfun _int _int _UINT _UINT _pointer -> _HBITMAP))
 (define-gdi32 CreateCompatibleDC (_wfun _HDC -> _HDC))
 (define-gdi32 DeleteDC (_wfun _HDC -> (r : _BOOL)
                               -> (unless r (failed 'DeleteDC))))
 
-(define (bitmap->hbitmap bm)
+(define (bitmap->hbitmap bm 
+                         #:mask [mask-bm #f]
+                         #:b&w? [b&w? #f] 
+                         #:bg [bg (GetSysColor COLOR_BTNFACE)])
   (let* ([w (send bm get-width)]
          [h (send bm get-height)]
-         [col (GetSysColor COLOR_BTNFACE)]
+         [mask-bm (or mask-bm
+                      (send bm get-loaded-mask))]
          [to-frac (lambda (v) (/ v 255.0))]
          [screen-hdc (GetDC #f)]
          [hdc (CreateCompatibleDC screen-hdc)]
-         [hbitmap (CreateCompatibleBitmap screen-hdc w h)]
+         [hbitmap (if b&w?
+                      (CreateBitmap w h 1 1 #f)
+                      (CreateCompatibleBitmap screen-hdc w h))]
          [old-hbitmap (SelectObject hdc hbitmap)])
     (ReleaseDC #f screen-hdc)
     (let* ([s (cairo_win32_surface_create hdc)]
            [cr (cairo_create s)])
       (cairo_surface_destroy s)
       (cairo_set_source_rgba cr 
-                             (to-frac (GetRValue col))
+                             (to-frac (GetRValue bg))
-                             (to-frac (GetGValue col))
+                             (to-frac (GetGValue bg))
-                             (to-frac (GetBValue col))
+                             (to-frac (GetBValue bg))
                              1.0)
       (cairo_paint cr)
-      (let ([p (cairo_get_source cr)])
+      (let ([mask-p (and mask-bm
-        (cairo_pattern_reference p)
+                         (cairo_pattern_create_for_surface 
-        (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
+                          (send mask-bm get-cairo-alpha-surface)))])
-        (cairo_new_path cr)
+        (let ([p (cairo_get_source cr)])
-        (cairo_rectangle cr 0 0 w h)
+          (cairo_pattern_reference p)
-        (cairo_fill cr)
+          (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
-        (cairo_set_source cr p)
+          (if mask-p
-        (cairo_pattern_destroy p))
+              (cairo_mask cr mask-p)
+              (begin
+                (cairo_new_path cr)
+                (cairo_rectangle cr 0 0 w h)
+                (cairo_fill cr)))
+          (when mask-p
+            (cairo_pattern_destroy mask-p))
+          (cairo_set_source cr p)
+          (cairo_pattern_destroy p)))
       (cairo_destroy cr)
       (SelectObject hdc old-hbitmap)
       (DeleteDC hdc)

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

@@ -8,6 +8,7 @@
          "const.rkt"
          "menu-item.rkt"
          "frame.rkt"
+         "dc.rkt"
 	 racket/draw)
 
 (provide
@@ -41,8 +42,6 @@
  is-color-display?
  file-selector
  id-to-menu-item
- get-the-x-selection
- get-the-clipboard
  show-print-setup
  can-show-print-setup?
  get-highlight-background-color
@@ -54,7 +53,11 @@
 (define-unimplemented special-option-key)
 (define-unimplemented get-color-from-user)
 (define-unimplemented get-font-from-user)
-(define (get-panel-background) (make-object color% "gray"))
+
+(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)
@@ -74,18 +77,17 @@
 (define (flush-display) (void))
 (define-unimplemented write-resource)
 (define-unimplemented get-resource)
-(define-unimplemented bell)
+
+(define-user32 MessageBeep (_wfun _UINT -> _BOOL))
+(define (bell)
+  (void (MessageBeep MB_OK)))
 
 (define (hide-cursor) (void))
 
-(define-unimplemented end-busy-cursor)
-(define-unimplemented is-busy?)
-(define-unimplemented begin-busy-cursor)
 (define (get-display-depth) 32)
+
 (define-unimplemented is-color-display?)
 (define-unimplemented file-selector)
-(define-unimplemented get-the-x-selection)
-(define-unimplemented get-the-clipboard)
 (define-unimplemented show-print-setup)
 (define (can-show-print-setup?) #f)
 
@@ -96,6 +98,8 @@
   (let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)])
     (make-object color% (GetRValue c) (GetGValue c) (GetBValue c))))
 
-(define-unimplemented make-screen-bitmap)
+(define/top (make-screen-bitmap [exact-positive-integer? w]
+                                [exact-positive-integer? h])
+  (make-object win32-bitmap% w h #f))
 
 (define (check-for-break) #f)

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

@@ -183,7 +183,7 @@
     (register-child-in-parent on?)
     (unless on? (not-focus-child this))
     (ShowWindow hwnd (if on? on-mode SW_HIDE)))
-  (unless (memq 'invisible style)
+  (unless (memq 'deleted style)
     (show #t))
   
   (def/public-unimplemented on-drop-file)
@@ -256,7 +256,6 @@
                       (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)
                       #t))
         (MoveWindow hwnd x y w h #t))
-    (on-size w h)
     (unless (and (= w -1) (= h -1))
       (on-resized))
     (refresh))