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

collecting-blit for cocoa

Browse Source 
original commit: 0691f0491e72728cba7769c2b2a9502bbd926d8b
This commit is contained in:
Matthew Flatt 2010-09-12 09:22:40 -06:00
parent eb677e9efb
commit 1c4ee63662
7 changed files with 159 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mred/private/gdi.rkt
View File

@ -32,6 +32,16 @@
[(canvas x y w h on off on-x on-y off-x) (register-collecting-blit canvas x y w h on off on-x on-y off-x 0)]
[(canvas x y w h on off on-x on-y off-x off-y)
(check-instance 'register-collecting-blit canvas% 'canvas% #f canvas)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit x)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit y)
((check-bounded-integer 0 10000 #f) 'register-collecting-blit w)
((check-bounded-integer 0 10000 #f) 'register-collecting-blit h)
(check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f on)
(check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f off)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-x)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-y)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-x)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-y)
(wx:register-collecting-blit (mred->wx canvas) x y w h on off on-x on-y off-x off-y)]))
(define unregister-collecting-blit

95
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -13,6 +13,8 @@
"cg.rkt"
"queue.rkt"
"item.rkt"
"gc.rkt"
"image.rkt"
"../common/backing-dc.rkt"
"../common/event.rkt"
"../common/queue.rkt"
@ -24,10 +26,14 @@
;; ----------------------------------------
(import-class NSView NSGraphicsContext NSScroller NSComboBox)
(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow NSImageView)
(import-protocol NSComboBoxDelegate)
(define NSWindowAbove 1)
(define o (current-error-port))
;; Called when a canvas has no backing store ready
(define (clear-background wxb)
(let ([wx (->wx wxb)])
@ -174,7 +180,8 @@
on-size
register-as-child
get-size get-position
set-focus)
set-focus
client-to-screen)
(define vscroll-ok? (and (memq 'vscroll style) #t))
(define vscroll? vscroll-ok?)
@ -336,7 +343,17 @@
(super show on?)
(fix-dc))
(define/override (hide-children)
(super hide-children)
(suspend-all-reg-blits))
(define/override (show-children)
(super show-children)
(resume-all-reg-blits))
(define/private (do-set-size x y w h)
(when (pair? blits)
(atomically (suspend-all-reg-blits)))
(super set-size x y w h)
(when tr
(tellv content-cocoa removeTrackingRect: #:type _NSInteger tr)
@ -369,6 +386,9 @@
(make-NSSize (max 0 (- w (if vscroll? scroll-width 0)
x-sb-margin x-sb-margin))
scroll-width))))
(when (and (pair? blits)
(is-shown-to-root?))
(atomically (resume-all-reg-blits)))
(fix-dc)
(when auto-scroll?
(reset-auto-scroll 0 0))
@ -708,4 +728,73 @@
(define/public (get-virtual-size xb yb)
(get-client-size xb yb)
(when virtual-width (set-box! xb virtual-width))
(when virtual-height (set-box! yb virtual-height)))))
(when virtual-height (set-box! yb virtual-height)))
(define blits null)
(define reg-blits null)
(define/private (suspend-all-reg-blits)
(let ([cocoa-win (get-cocoa-window)])
(for ([r (in-list reg-blits)])
(tellv cocoa-win removeChildWindow: (car r))
(release (car r))
(scheme_remove_gc_callback (cdr r))))
(set! reg-blits null))
(define/public (resume-all-reg-blits)
(unless (pair? reg-blits)
(when (pair? blits)
(set! reg-blits
(for/list ([b (in-list blits)])
(let-values ([(x y w h img) (apply values b)])
(register-one-blit x y w h img)))))))
(define/private (register-one-blit x y w h img)
(let ([xb (box x)]
[yb (box y)])
(client-to-screen xb yb #f)
(let* ([cocoa-win (get-cocoa-window)])
(atomically
(let ([win (as-objc-allocation
(tell (tell NSWindow alloc)
initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb)
(- (unbox yb)
h))
(make-NSSize w h))
styleMask: #:type _int NSBorderlessWindowMask
backing: #:type _int NSBackingStoreBuffered
defer: #:type _BOOL NO))]
[iv (tell (tell NSImageView alloc) init)])
(tellv iv setImage: img)
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h)))
(tellv (tell win contentView) addSubview: iv)
(tellv win setAlphaValue: #:type _CGFloat 0.0)
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
(tellv iv release)
(let ([r (scheme_add_gc_callback
(make-gc-action-desc win (selector setAlphaValue:) 1.0)
(make-gc-action-desc win (selector setAlphaValue:) 0.0))])
(cons win r)))))))
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
(let ([on (if (and (zero? on-x)
(zero? on-y)
(= (send on get-width) w)
(= (send on get-height) h))
on
(let ([bm (make-object bitmap% w h)])
(let ([dc (make-object bitmap-dc% on)])
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
(send dc set-bitmap #f)
bm)))])
(let ([img (bitmap->image on)])
(atomically
(set! blits (cons (list x y w h img) blits))
(when (is-shown-to-root?)
(set! reg-blits (cons (register-one-blit x y w h img) reg-blits)))))))
(define/public (unregister-collecting-blits)
(atomically
(suspend-all-reg-blits)
(set! blits null)))))

10
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -204,6 +204,9 @@
(eq? front this))
(set! front #f)
(send empty-mb install))
(if on?
(show-children)
(hide-children))
(if on?
(begin
(when is-a-dialog?
@ -281,6 +284,13 @@
(when child-sheet (send child-sheet destroy))
(direct-show #f))
(define/override (hide-children)
(when saved-child
(send saved-child hide-children)))
(define/override (show-children)
(when saved-child
(send saved-child show-children)))
(define/override (is-shown?)
(tell #:type _bool cocoa isVisible))

26
collects/mred/private/wx/cocoa/gc.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"types.rkt")
(provide scheme_add_gc_callback
scheme_remove_gc_callback
make-gc-action-desc)
(define objc-lib (ffi-lib "libobjc"))
(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer))
(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
(define (make-gc-action-desc win sel val)
(vector
(vector (if (= (ctype-sizeof _CGFloat) 4)
'ptr_ptr_float->void
'ptr_ptr_double->void)
msg-send-proc
win
sel
val)))

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

@ -37,6 +37,10 @@
(define/override (hide-children)
(for ([child (in-list children)])
(send child hide-children)))
(define/override (show-children)
(for ([child (in-list children)])
(send child show-children)))
(define/override (paint-children)
(for ([child (in-list children)])

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

@ -68,8 +68,10 @@
(define-unimplemented play-sound)
(define-unimplemented check-for-break)
(define-unimplemented find-graphical-system-path)
(define (register-collecting-blit . args) (void))
(define (unregister-collecting-blit . args) (void))
(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 in-atomic-region)
(define (set-menu-tester proc)

20
collects/mred/private/wx/cocoa/window.rkt
View File

@ -332,6 +332,8 @@
(define/public (hide-children)
(is-responder this #f)
(focus-is-on #f))
(define/public (show-children)
(void))
(define/public (fix-dc)
(void))
(define/public (paint-children)
@ -364,11 +366,13 @@
(tellv (send parent get-cocoa-content) addSubview: cocoa)
(with-autorelease
(tellv cocoa removeFromSuperview)))
(set! is-on? (and on? #t))))
(maybe-register-as-child parent on?)
(unless on?
(hide-children)
(is-responder this #f)))
(set! is-on? (and on? #t))
(maybe-register-as-child parent on?)
(if on?
(show-children)
(begin
(hide-children)
(is-responder this #f))))))
(define/public (maybe-register-as-child parent on?)
;; override this to call register-as-child if the window
;; can have the focus or otherwise needs show-state notifications.
@ -575,14 +579,16 @@
(set-box! xb (inexact->exact (floor (NSPoint-x p))))
(set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
(define/public (client-to-screen xb yb)
(define/public (client-to-screen xb yb [flip-y? #t])
(let* ([p (tell #:type _NSPoint (get-cocoa-window)
convertBaseToScreen:
#:type _NSPoint
(tell #:type _NSPoint (get-cocoa-content)
convertPointToBase: #:type _NSPoint
(make-NSPoint (unbox xb) (flip-client (unbox yb)))))])
(let ([new-y (send (get-wx-window) flip-screen (NSPoint-y p))])
(let ([new-y (if flip-y?
(send (get-wx-window) flip-screen (NSPoint-y p))
(NSPoint-y p))])
(set-box! xb (inexact->exact (floor (NSPoint-x p))))
(set-box! yb (inexact->exact (floor new-y))))))