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

fixes to bitmap%, especially mask vs. alpha mode

Browse Source 
original commit: 439683af5e938a0662139e5af90f65103d8c53cb
This commit is contained in:
Matthew Flatt 2010-08-01 06:57:03 -06:00
parent 5803fd7758
commit f30792e085
5 changed files with 13 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mred/private/wx/cocoa/image.rkt
View File

@ -57,8 +57,9 @@
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(when (send bm get-loaded-mask)
(send bm get-argb-pixels 0 0 w h str #t))
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])

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

@ -95,7 +95,7 @@
(define-unimplemented draw-tab-base)
(define-unimplemented key-symbol-to-integer)
(define (get-control-font-size) 13)
(define-unimplemented cancel-quit)
(define (cancel-quit) (void))
(define-unimplemented fill-private-color)
(define (flush-display) (void))
(define-unimplemented write-resource)

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

@ -33,9 +33,9 @@
(define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate)
[]
[-a _BOOL (applicationShouldTerminate: [_id app])
[-a _int (applicationShouldTerminate: [_id app])
(queue-quit-event)
#f]
0]
[-a _BOOL (openPreferences: [_id app])
(log-error "prefs")
#t])

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

@ -56,8 +56,10 @@
[(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)]
[(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)]
[else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])
(gtk_image_new_from_pixbuf
(bitmap->pixbuf label))))]
(if (send label ok?)
(gtk_image_new_from_pixbuf
(bitmap->pixbuf label))
(gtk_label_new_with_mnemonic "<bad-image>"))))]
[no-show? (memq 'deleted style)])
(set-auto-size)

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

@ -36,8 +36,9 @@
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(when (send bm get-loaded-mask)
(send bm get-argb-pixels 0 0 w h str #t))
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])