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

win32: misc repairs

Browse Source 
original commit: d4f7df6eb88d235e58fc54502acfdcbeb081132c
This commit is contained in:
Matthew Flatt 2010-10-12 07:53:38 -06:00
parent d7afaed869
commit 7dd7553379
10 changed files with 96 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

2
collects/mred/private/wx/win32/button.rkt
View File

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

4
collects/mred/private/wx/win32/canvas.rkt
View File

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

24
collects/mred/private/wx/win32/dc.rkt
View File

@ -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)
(cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
(atomically
(let ([hdc (GetDC hwnd)])
(begin0
(cairo_win32_surface_create_with_ddb hdc
CAIRO_FORMAT_RGB24 w h)
(ReleaseDC hwnd hdc))))))
(let ([s
(if (not hwnd)
(cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
(atomically
(let ([hdc (GetDC hwnd)])
(begin0
(cairo_win32_surface_create_with_ddb 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)

32
collects/mred/private/wx/win32/frame.rkt
View File

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

1
collects/mred/private/wx/win32/group-panel.rkt
View File

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

43
collects/mred/private/wx/win32/hbitmap.rkt
View File

@ -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 (GetGValue col))
(to-frac (GetBValue col))
(to-frac (GetRValue bg))
(to-frac (GetGValue bg))
(to-frac (GetBValue bg))
1.0)
(cairo_paint cr)
(let ([p (cairo_get_source cr)])
(cairo_pattern_reference p)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 w h)
(cairo_fill cr)
(cairo_set_source cr p)
(cairo_pattern_destroy p))
(let ([mask-p (and mask-bm
(cairo_pattern_create_for_surface
(send mask-bm get-cairo-alpha-surface)))])
(let ([p (cairo_get_source cr)])
(cairo_pattern_reference p)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(if mask-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)

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

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

3
collects/mred/private/wx/win32/window.rkt
View File

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