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

fix canvases in tab panels

Browse Source
This commit is contained in:
Matthew Flatt 2010-07-28 07:17:01 -05:00
parent d7289c253f
commit 82c0a1cc29
6 changed files with 82 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,12 +16,35 @@
(define (panel-mixin %)
(class %
(inherit register-as-child)
(define lbl-pos 'horizontal)
(define children null)
(super-new)
(define/public (get-label-position) lbl-pos)
(define/public (set-label-position pos) (set! lbl-pos pos))
(define/public (fix-dc)
(for ([child (in-list children)])
(send child fix-dc)))
(define/override (set-size x y w h)
(super set-size x y w h)
(fix-dc))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/override (register-child child on?)
(let ([now-on? (and (memq child children) #t)])
(unless (eq? on? now-on?)
(set! children
(if on?
(cons child children)
(remq child children))))))
(def/public-unimplemented on-paint)
(define/public (set-item-cursor x y) (void))
(def/public-unimplemented get-item-cursor)))
@ -31,29 +54,6 @@
x y w h
style
label)
(inherit register-as-child)
(define children null)
(define/public (fix-dc)
(for ([child (in-list children)])
(send child fix-dc)))
(define/override (set-size x y w h)
(super set-size x y w h)
(fix-dc))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/override (register-child child on?)
(let ([now-on? (and (memq child children) #t)])
(unless (eq? on? now-on?)
(set! children
(if on?
(cons child children)
(remq child children))))))
(super-new [parent parent]
[cocoa
(as-objc-allocation

15
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -84,7 +84,8 @@
[ignored-name #f]
[gl-config #f])
(inherit get-gtk set-size get-client-size)
(inherit get-gtk set-size get-size get-client-size
on-size register-as-child)
(define client-gtk (gtk_drawing_area_new))
(define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box)
@ -196,9 +197,19 @@
(define/override (refresh)
(gtk_widget_queue_draw client-gtk))
(define/public (reset-child-dcs)
(send dc reset-dc #t))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/override (internal-on-client-size w h)
(send dc reset-dc-size))
(send dc reset-dc #f))
(define/override (on-client-size w h)
(let ([xb (box 0)]
[yb (box 0)])
(get-size xb yb)
(on-size (unbox xb) (unbox yb))))
(define/public (show-scrollbars h? v?)
(when hscroll-gtk

9
collects/mred/private/wx/gtk/dc.rkt
View File

@ -9,13 +9,13 @@
racket/draw/local
ffi/unsafe/alloc)
(provide dc% reset-dc-size)
(provide dc% reset-dc)
(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
#:wrap (allocator cairo_destroy))
(define-local-member-name
reset-dc-size)
reset-dc)
(define dc-backend%
(class default-dc-backend%
@ -31,8 +31,9 @@
(set! c (gdk_cairo_create w))
c))))
(define/public (reset-dc-size)
(when (eq? 'windows (system-type))
(define/public (reset-dc force?)
(when (or force?
(eq? 'windows (system-type)))
;; FIXME: ensure that the dc is not in use
(as-entry
(lambda ()

26
collects/mred/private/wx/gtk/panel.rkt
View File

@ -17,12 +17,36 @@
(define (panel-mixin %)
(class %
(define lbl-pos 'vertical)
(inherit register-as-child)
(define lbl-pos 'horizontal)
(define children null)
(super-new)
(define/public (get-label-position) lbl-pos)
(define/public (set-label-position pos) (set! lbl-pos pos))
(define/public (reset-child-dcs)
(when (pair? children)
(for ([child (in-list children)])
(send child reset-child-dcs))))
(define/override (set-size x y w h)
(super set-size x y w h)
(reset-child-dcs))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/override (register-child child on?)
(let ([now-on? (and (memq child children) #t)])
(unless (eq? on? now-on?)
(set! children
(if on?
(cons child children)
(remq child children))))))
(def/public-unimplemented on-paint)
(define/public (set-item-cursor x y) (void))
(def/public-unimplemented get-item-cursor)))

7
collects/mred/private/wx/gtk/tab-panel.rkt
View File

@ -45,7 +45,8 @@
style
labels)
(inherit set-size set-auto-size get-gtk)
(inherit set-size set-auto-size get-gtk
reset-child-dcs)
(define gtk (gtk_notebook_new))
;; Reparented so that it's always in the current page's bin:
@ -56,7 +57,9 @@
(define (select-bin bin-gtk)
(set! current-bin-gtk bin-gtk)
(gtk_box_pack_start bin-gtk client-gtk #t #t 0))
(gtk_box_pack_start bin-gtk client-gtk #t #t 0)
;; re-parenting can change the underlying window dc:
(reset-child-dcs))
(define pages
(for/list ([lbl labels])

13
collects/mred/private/wx/gtk/window.rkt
View File

@ -255,7 +255,8 @@
(if on?
(gtk_widget_show gtk)
(gtk_widget_hide gtk))
(set! shown? (and on? #t)))
(set! shown? (and on? #t))
(maybe-register-as-child parent on?))
(define/public (show on?)
(direct-show on?))
(define/public (is-shown?) shown?)
@ -325,8 +326,16 @@
(define/public (on-char e) (void))
(define/public (on-event e) (void))
(define/public (on-size w h) (void))
(define/public (maybe-register-as-child parent on?)
(void))
(define/public (register-as-child parent on?)
(send parent register-child this on?))
(define/public (register-child child on?)
(void))
(def/public-unimplemented on-drop-file)
(def/public-unimplemented on-size)
(def/public-unimplemented get-handle)
(def/public-unimplemented set-phantom-size)
(def/public-unimplemented popup-menu)