win32 theme and basic canvas

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

@@ -54,7 +54,7 @@
     (super-make-object (make-alternate-bitmap-kind w h))
 
     (define s
-      (if gdk-win
+      (if (not gdk-win)
 	  (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
 	  (atomically
 	   (let ([hdc (GetDC (gdk_win32_drawable_get_handle gdk-win))])

collects/mred/private/wx/platform.rkt

@@ -4,7 +4,7 @@
 
 (define-runtime-path platform-lib
   (case (system-type)
-    [() '(lib "mred/private/wx/win32/platform.rkt")]
+    [(#;windows) '(lib "mred/private/wx/win32/platform.rkt")]
     [(macosx) '(lib "mred/private/wx/cocoa/platform.rkt")]
     [(windows unix) '(lib "mred/private/wx/gtk/platform.rkt")]))
 

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

@@ -27,6 +27,6 @@
 			       #f)]
 	     [style style])
 
-  (auto-size label 50 14)
+  (auto-size label 40 12 12 0)
 
   (def/public-unimplemented set-border))

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

@@ -1,32 +1,132 @@
-#lang scheme/base
+#lang racket/base
-(require scheme/class
+(require racket/class
-          "../../syntax.rkt"
+         ffi/unsafe
-         "window.rkt")
+         racket/draw
+         "../../syntax.rkt"
+         "../../lock.rkt"
+         "../common/canvas-mixin.rkt"
+         "../common/backing-dc.rkt"
+         "utils.rkt"
+         "types.rkt"
+         "const.rkt"
+         "wndclass.rkt"
+         "window.rkt"
+         "dc.rkt")
 
 (provide canvas%)
 
-(defclass canvas% window%
+(define-user32 GetDC (_wfun _HWND -> _HDC))
-  (def/public-unimplemented get-canvas-background)
+(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
-  (def/public-unimplemented set-canvas-background)
+(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
-  (def/public-unimplemented set-background-to-gray)
+(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> _BOOL))
-  (def/public-unimplemented on-scroll)
+
-  (def/public-unimplemented set-scroll-page)
+(define canvas% 
-  (def/public-unimplemented set-scroll-range)
+  (canvas-mixin
-  (def/public-unimplemented set-scroll-pos)
+   (class window%
-  (def/public-unimplemented get-scroll-page)
+     (init parent
-  (def/public-unimplemented get-scroll-range)
+           x y w h
-  (def/public-unimplemented get-scroll-pos)
+           style
-  (def/public-unimplemented scroll)
+           [ignored-name #f]
-  (def/public-unimplemented warp-pointer)
+           [gl-config #f])
-  (def/public-unimplemented view-start)
+
-  (def/public-unimplemented set-resize-corner)
+     (inherit get-win32
-  (def/public-unimplemented show-scrollbars)
+              get-client-size)
-  (def/public-unimplemented set-scrollbars)
+
-  (def/public-unimplemented get-virtual-size)
+     (define hscroll? (memq 'hscroll style))
-  (def/public-unimplemented get-dc)
+     (define vscroll? (memq 'vscroll style))
-  (def/public-unimplemented on-char)
+
-  (def/public-unimplemented on-event)
+     (super-new [parent parent]
-  (def/public-unimplemented on-paint)
+                [win32
-  (def/public-unimplemented begin-refresh-sequence)
+                 (CreateWindowExW 0
-  (def/public-unimplemented end-refresh-sequence)
+                                  "PLTCanvas"
-  (super-new))
+                                  #f
+                                  (bitwise-ior WS_CHILD WS_VISIBLE
+                                               (if hscroll? WS_HSCROLL 0)
+                                               (if vscroll? WS_VSCROLL 0))
+                                  0 0 w h
+                                  (send parent get-win32)
+                                  #f
+                                  hInstance
+                                  #f)]
+                [style style])
+
+     (define win32 (get-win32))
+
+     (define/override (wndproc w msg wparam lparam)
+       (cond
+        [(= msg WM_PAINT)
+         (let* ([ps (malloc 128)]
+                [hdc (BeginPaint w ps)])
+           (unless (positive? paint-suspended)
+             (unless (do-backing-flush this dc hdc)
+               (queue-paint))
+             (do-backing-flush this dc hdc))
+           (EndPaint hdc ps))
+         0]
+        [else (super wndproc w msg wparam lparam)]))
+     
+     (define dc (new dc% [canvas this]))
+
+     (define/public (get-dc) dc)
+
+     ;; The `queue-paint' and `paint-children' methods
+     ;; are defined by `canvas-mixin' from ../common/canvas-mixin
+     (define/public (queue-paint) (void))
+     (define/public (request-canvas-flush-delay)
+       (request-flush-delay this))
+     (define/public (cancel-canvas-flush-delay req)
+       (cancel-flush-delay req))
+     (define/public (queue-canvas-refresh-event thunk)
+       (queue-window-refresh-event this thunk))
+
+     (define/public (get-flush-window) win32)
+
+     (define/public (begin-refresh-sequence)
+       (send dc suspend-flush))
+     (define/public (end-refresh-sequence)
+       (send dc resume-flush))
+
+     (define/public (on-paint) (void))
+     (define/override (refresh) (queue-paint))
+
+     (define/public (queue-backing-flush)
+       (void (InvalidateRect win32 #f #t)))
+
+     (define/public (make-compatible-bitmap w h)
+       (send dc make-backing-bitmap w h))
+
+     (define paint-suspended 0)
+     (define/public (suspend-paint-handling)
+       (atomically
+        (set! paint-suspended (add1 paint-suspended))))
+     (define/public (resume-paint-handling)
+       (atomically
+        (unless (zero? paint-suspended)
+          (set! paint-suspended (sub1 paint-suspended)))))
+
+     (define/public (get-virtual-size w h)
+       (get-client-size w h))
+
+     (define transparent? (memq 'transparent style))
+     (define bg-col (make-object color% "white"))
+     (define/public (get-canvas-background) (if transparent?
+                                                #f
+                                                bg-col))
+     (define/public (set-canvas-background col) (set! bg-col col))
+
+     (def/public-unimplemented set-background-to-gray)
+     (def/public-unimplemented on-scroll)
+     (def/public-unimplemented set-scroll-page)
+     (def/public-unimplemented set-scroll-range)
+     (def/public-unimplemented set-scroll-pos)
+     (def/public-unimplemented get-scroll-page)
+     (def/public-unimplemented get-scroll-range)
+     (def/public-unimplemented get-scroll-pos)
+     (def/public-unimplemented scroll)
+     (def/public-unimplemented warp-pointer)
+     (def/public-unimplemented view-start)
+     (def/public-unimplemented set-resize-corner)
+     (def/public-unimplemented show-scrollbars)
+     (def/public-unimplemented set-scrollbars)
+     (def/public-unimplemented on-char)
+     (def/public-unimplemented on-event))))

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

@@ -0,0 +1,114 @@
+#lang racket/base
+(require ffi/unsafe
+         racket/class
+         "utils.rkt"
+         "types.rkt"
+	 "../../lock.rkt"
+         "../common/backing-dc.rkt"
+         "../common/delay.rkt"
+         racket/draw/cairo
+         racket/draw/dc
+         racket/draw/bitmap
+         racket/draw/local
+         ffi/unsafe/alloc)
+
+(provide dc%
+         do-backing-flush
+         request-flush-delay
+         cancel-flush-delay)
+
+(define-user32 GetDC (_wfun  _HWND -> _HDC))
+(define-user32 ReleaseDC (_wfun _HDC -> _void))
+
+(define win32-bitmap%
+  (class bitmap%
+    (init w h win32)
+    (super-make-object (make-alternate-bitmap-kind w h))
+
+    (define s
+      (if (not win32)
+	  (cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
+	  (atomically
+	   (let ([hdc (GetDC win32)])
+	     (begin0
+	      (cairo_win32_surface_create_with_ddb hdc
+						   CAIRO_FORMAT_RGB24 w h)
+	      (ReleaseDC hdc))))))
+
+    (define/override (ok?) #t)
+    (define/override (is-color?) #t)
+    (define/override (has-alpha-channel?) #f)
+
+    (define/override (get-cairo-surface) s)
+
+    (define/override (release-bitmap-storage)
+      (atomically
+       (cairo_surface_destroy s)
+       (set! s #f)))))
+
+(define dc%
+  (class backing-dc%
+    (init [(cnvs canvas)])
+    (inherit end-delay)
+    (define canvas cnvs)
+
+    (super-new)
+
+    (define/override (make-backing-bitmap w h)
+      (if (send canvas get-canvas-background)
+          (make-object win32-bitmap% w h (send canvas get-win32))
+          (super make-backing-bitmap w h)))
+
+    (define/override (get-backing-size xb yb)
+      (send canvas get-client-size xb yb))
+
+    (define/override (get-size)
+      (let ([xb (box 0)]
+            [yb (box 0)])
+        (send canvas get-virtual-size xb yb)
+        (values (unbox xb) (unbox yb))))
+
+    (define/override (queue-backing-flush)
+      ;; Re-enable expose events so that the queued 
+      ;; backing flush will be handled:
+      (end-delay)
+      (send canvas queue-backing-flush))
+
+    (define/override (request-delay)
+      (request-flush-delay canvas))
+    (define/override (cancel-delay req)
+      (cancel-flush-delay req))))
+
+(define (do-backing-flush canvas dc hdc)
+  (send dc on-backing-flush
+        (lambda (bm)
+          (let ([w (box 0)]
+                [h (box 0)])
+            (send canvas get-client-size w h)
+            (let* ([surface (cairo_win32_surface_create hdc)]
+                   [cr (cairo_create surface)])
+              (cairo_surface_destroy surface)
+              (let ([s (cairo_get_source cr)])
+                (cairo_pattern_reference s)
+                (cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
+                (cairo_new_path cr)
+                (cairo_rectangle cr 0 0 (unbox w) (unbox h))
+                (cairo_fill cr)
+                (cairo_set_source cr s)
+                (cairo_pattern_destroy s))
+              (cairo_destroy cr))))))
+
+(define (request-flush-delay canvas)
+  (do-request-flush-delay 
+   canvas
+   (lambda (gtk)
+     (send canvas suspend-paint-handling))
+   (lambda (gtk)
+     (send canvas resume-paint-handling))))
+
+(define (cancel-flush-delay req)
+  (when req
+    (do-cancel-flush-delay 
+     req
+     (lambda (canvas)
+       (send canvas resume-paint-handling)))))

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

@@ -1,6 +1,7 @@
 #lang racket/base
 (require racket/class
 	 "../../syntax.rkt"
+	 "theme.rkt"
 	 racket/draw)
 
 (provide
@@ -57,7 +58,7 @@
 (define-unimplemented file-creator-and-type)
 (define-unimplemented run-printout)
 (define (get-double-click-time) 500)
-(define (get-control-font-size) 10)
+(define (get-control-font-size) (get-theme-font-size))
 (define-unimplemented cancel-quit)
 (define-unimplemented fill-private-color)
 (define-unimplemented flush-display)

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

@@ -11,6 +11,7 @@
          ;; from common/queue:
          current-eventspace
          queue-event
+         queue-refresh-event
          yield)
 
 ;; ------------------------------------------------------------
@@ -37,7 +38,7 @@
 (define msg (malloc _MSG 'raw))
 
 (define (events-ready?)
-  (GetQueueStatus QS_ALLINPUT))
+  (not (zero? (GetQueueStatus QS_ALLINPUT))))
 
 (define (install-wakeup fds)
   (pre-event-sync #t)

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

@@ -0,0 +1,78 @@
+#lang racket/base
+(require ffi/unsafe
+         "utils.ss"
+         "const.ss"
+         "types.ss")
+
+(provide get-theme-logfont
+	 get-theme-font-face
+	 get-theme-font-size
+	 _LOGFONT-pointer)
+
+(define _HTHEME (_cpointer 'HTHEME))
+
+(define-cstruct _FaceName1
+  ([c1 _uint16]
+   [c2 _uint16]
+   [c3 _uint16]
+   [c4 _uint16]
+   [c5 _uint16]
+   [c6 _uint16]
+   [c7 _uint16]
+   [c8 _uint16]))
+
+(define-cstruct _FaceName
+  ([f1 _FaceName1]
+   [f2 _FaceName1]
+   [f3 _FaceName1]
+   [f4 _FaceName1]))
+
+(define-cstruct _LOGFONT
+  ([lfHeight  _LONG]
+   [lfWidth  _LONG]
+   [lfEscapement  _LONG]
+   [lfOrientation  _LONG]
+   [lfWeight  _LONG]
+   [lfItalic  _BYTE]
+   [lfUnderline  _BYTE]
+   [lfStrikeOut  _BYTE]
+   [lfCharSet  _BYTE]
+   [lfOutPrecision  _BYTE]
+   [lfClipPrecision  _BYTE]
+   [lfQuality  _BYTE]
+   [lfPitchAndFamily  _BYTE]
+   [lfFaceName _FaceName])) ; 32 of them
+
+(define-uxtheme OpenThemeData (_wfun _HWND _string/utf-16 -> _HTHEME))
+(define-uxtheme CloseThemeData (_wfun _HTHEME -> (r : _HRESULT)
+				      -> (when (negative? r)
+					   (error 'CloseThemeData "failed: ~s" (bitwise-and #xFFFF r)))))
+(define-uxtheme GetThemeFont (_wfun _HTHEME _HDC _int _int _int (f : (_ptr o _LOGFONT))
+				    -> (r : _HRESULT)
+				    -> (if (negative? r) 
+					   (error 'GetThemeFont "failed: ~s" (bitwise-and #xFFFF r))
+					   f)))
+
+(define-uxtheme GetThemeSysFont(_wfun (_or-null _HTHEME) _int (f : (_ptr o _LOGFONT))
+				      -> (r : _HRESULT)
+				      -> (if (negative? r) 
+					     (error 'GetThemeSysFont "failed: ~s" (bitwise-and #xFFFF r))
+					     f)))
+
+(define BP_PUSHBUTTON 1)
+(define PBS_NORMAL 1)
+(define TMT_FONT 210)
+(define TMT_BODYFONT 809)
+
+(define TMT_MSGBOXFONT 805)
+
+(define theme-logfont (GetThemeSysFont #f TMT_MSGBOXFONT))
+
+(define (get-theme-logfont)
+  theme-logfont)
+
+(define (get-theme-font-face)
+  (cast (LOGFONT-lfFaceName theme-logfont) _pointer _string/utf-16))
+
+(define (get-theme-font-size)
+  (abs (LOGFONT-lfHeight theme-logfont)))

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

@@ -12,6 +12,7 @@
 	 _UINT
 	 _BYTE
 	 _LONG
+	 _HRESULT
 
 	 _HINSTANCE
 	 _HWND
@@ -20,6 +21,7 @@
 	 _HCURSOR
 	 _HBRUSH
 	 _HDC
+	 _HFONT
 
 	 _COLORREF
 
@@ -41,6 +43,7 @@
 (define _BOOL (make-ctype _int (lambda (v) (if v 1 0)) (lambda (v) (not (zero? v)))))
 (define _UINT _uint)
 (define _BYTE _uint8)
+(define _HRESULT _int32)
 
 (define _HINSTANCE (_cpointer/null 'HINSTANCE))
 (define _HWND (_cpointer/null 'HWND))
@@ -49,6 +52,7 @@
 (define _HCURSOR (_cpointer/null 'HCURSOR))
 (define _HBRUSH (_cpointer/null 'HBRUSH))
 (define _HDC (_cpointer/null 'HDC))
+(define _HFONT (_cpointer/null 'HFONT))
 
 (define _COLORREF _DWORD)
 

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

@@ -3,15 +3,21 @@
 	 ffi/unsafe/define
          "../common/utils.rkt")
 
-(provide define-user32
+(provide define-gdi32
+	 define-user32
 	 define-kernel32
 	 define-comctl32
+	 define-uxtheme
          define-mz)
 
+(define gdi32-lib (ffi-lib "gdi32.dll"))
 (define user32-lib (ffi-lib "user32.dll"))
 (define kernel32-lib (ffi-lib "kernel32.dll"))
 (define comctl32-lib (ffi-lib "comctl32.dll"))
+(define uxtheme-lib (ffi-lib "uxtheme.dll"))
 
+(define-ffi-definer define-gdi32 gdi32-lib)
 (define-ffi-definer define-user32 user32-lib)
 (define-ffi-definer define-kernel32 kernel32-lib)
 (define-ffi-definer define-comctl32 comctl32-lib)
+(define-ffi-definer define-uxtheme uxtheme-lib)

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

@@ -5,11 +5,14 @@
           "../../syntax.rkt"
 	 "utils.rkt"
 	 "types.rkt"
+	 "const.rkt"
 	 "wndclass.rkt"
-	 "queue.rkt")
+	 "queue.rkt"
+	 "theme.rkt")
 
 (provide window%
 	 queue-window-event
+	 queue-window-refresh-event
 	 
 	 CreateWindowExW
 	 GetWindowRect)
@@ -24,6 +27,10 @@
 (define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r))
 (define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r))
 
+(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
+
+(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
+
 (define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL))
 
 (define-user32 ShowWindow (_wfun _HWND _int -> _BOOL))
@@ -33,9 +40,11 @@
 (define-user32 GetDialogBaseUnits (_fun -> _LONG))
 (define measure-dc #f)
 
+(define theme-hfont #f)
+
 (define-values (dlu-x dlu-y)
   (let ([v (GetDialogBaseUnits)])
-    (values (* 1/4 (bitwise-and v #xFF))
+    (values (* 1/4 (bitwise-and v #xFFFF))
 	    (* 1/8 (arithmetic-shift v -16)))))
 
 (defclass window% object%
@@ -88,6 +97,8 @@
 
   (def/public-unimplemented set-phantom-size)
 
+  (define/public (paint-children) (void))
+
   (define/public (get-x)
     (let ([r (GetWindowRect win32)])
       (- (RECT-left r) (send parent get-x))))
@@ -119,7 +130,10 @@
   (define/public (move x y)
     (set-size x y -1 -1))
 
-  (define/public (auto-size label min-w min-h)
+  (define/public (auto-size label min-w min-h dw dh)
+    (unless theme-hfont
+      (set! theme-hfont (CreateFontIndirectW (get-theme-logfont))))
+    (SendMessageW win32 WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)
     (unless measure-dc
       (let* ([bm (make-object bitmap% 1 1)]
 	     [dc (make-object bitmap-dc% bm)]
@@ -129,8 +143,8 @@
     (let-values ([(w h d a) (send measure-dc get-text-extent label #f #t)]
 		 [(->int) (lambda (v) (inexact->exact (floor v)))])
       (set-size -11111 -11111 
-		(max (->int w) (->int (* dlu-x min-w)))
+		(max (->int (+ w dw)) (->int (* dlu-x min-w)))
-		(max (->int h) (->int (* dlu-y min-h))))))
+		(max (->int (+ h dh)) (->int (* dlu-y min-h))))))
 
   (def/public-unimplemented popup-menu)
   (def/public-unimplemented center)
@@ -140,7 +154,10 @@
   (def/public-unimplemented refresh)
   (def/public-unimplemented screen-to-client)
   (def/public-unimplemented client-to-screen)
-  (def/public-unimplemented drag-accept-files)
+
+  (define/public (drag-accept-files on?)
+    (void))
+
   (def/public-unimplemented enable)
   (def/public-unimplemented get-position)
 
@@ -160,3 +177,6 @@
 
 (define (queue-window-event win thunk)
   (queue-event (send win get-eventspace) thunk))
+
+(define (queue-window-refresh-event win thunk)
+  (queue-refresh-event (send win get-eventspace) thunk))

collects/racket/draw/font-dir.rkt

@@ -54,6 +54,7 @@
         [(script) "Chancery"]
         [(symbol) "Symbol"]
         [else (case (system-type)
+		[(windows) "Tahoma"]
                 [(macosx) "Lucida Grande"]
                 [else "Sans"])]))