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

implement 'border style for `panel%'

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-13 06:25:07 -06:00
parent 093d2304a8
commit 461af202c5
7 changed files with 115 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -94,18 +94,6 @@
#:mixins (MyViewMixin)
[wxb])
(define-objc-class FrameView NSView
[]
(-a _void (drawRect: [_NSRect r])
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[r (tell #:type _NSRect self bounds)])
(CGContextSetRGBFillColor cg 0 0 0 1.0)
(CGContextAddRect cg r)
(CGContextStrokePath cg))
(tellv ctx restoreGraphicsState))))
(define-objc-class CornerlessFrameView NSView
[]
(-a _void (drawRect: [_NSRect r])

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

@ -5,18 +5,33 @@
"../../syntax.rkt"
"types.rkt"
"utils.rkt"
"cg.rkt"
"window.rkt")
(provide
(protect-out panel%
panel-mixin))
panel-mixin
(import-class NSView)
FrameView))
(import-class NSView NSGraphicsContext)
(define-objc-class MyPanelView NSView
#:mixins (KeyMouseTextResponder CursorDisplayer)
[wxb])
(define-objc-class FrameView NSView
[]
(-a _void (drawRect: [_NSRect r])
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[r (tell #:type _NSRect self bounds)])
(CGContextSetRGBFillColor cg 0 0 0 1.0)
(CGContextAddRect cg r)
(CGContextStrokePath cg))
(tellv ctx restoreGraphicsState))))
(define (panel-mixin %)
(class %
(inherit register-as-child on-new-child
@ -92,14 +107,47 @@
(define/public (set-item-cursor x y) (void))))
(defclass panel% (panel-mixin window%)
(inherit get-cocoa)
(init parent
x y w h
style
label)
(define has-border? (memq 'border style))
(super-new [parent parent]
[cocoa
(as-objc-allocation
(tell (tell MyPanelView alloc)
(tell (tell (if has-border? FrameView MyPanelView) alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize (max 1 w) (max 1 h)))))]
[no-show? (memq 'deleted style)]))
(make-NSSize (max (if has-border? 3 1) w)
(max (if has-border? 3 1) h)))))]
[no-show? (memq 'deleted style)])
(define content-cocoa
(and has-border?
(let* ([c (get-cocoa)]
[f (tell #:type _NSRect c frame)])
(as-objc-allocation
(tell (tell MyPanelView alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point 1 1)
(let ([s (NSRect-size f)])
(make-NSSize (max 1 (- (NSSize-width s) 2))
(max 1 (- (NSSize-height s) 2))))))))))
(when has-border?
(let ([cocoa (get-cocoa)])
(tell #:type _void cocoa addSubview: content-cocoa)
(set-ivar! content-cocoa wxb (->wxb this))))
(define/override (get-cocoa-content)
(if has-border?
content-cocoa
(super get-cocoa-content)))
(define/override (set-size x y w h)
(super set-size x y w h)
(when has-border?
(tellv content-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 1 1)
(make-NSSize (max 1 (- w 2)) (max 1 (- h 2))))))))

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

@ -100,18 +100,9 @@
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void))
(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void)
#:c-id g_object_set)
(define-gdk gdk_gc_unref (_fun _pointer -> _void)
#:wrap (deallocator))
(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer)
#:wrap (allocator gdk_gc_unref))
(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void))
(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void))
(define _GtkIMContext (_cpointer 'GtkIMContext))
(define-gtk gtk_im_multicontext_new (_fun -> _GtkIMContext))
(define-gtk gtk_im_context_set_use_preedit (_fun _GtkIMContext _gboolean -> _void))
@ -201,22 +192,6 @@
(not (send wx is-panel?)))
#f))))
(define-signal-handler connect-expose-border "expose-event"
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let* ([win (widget-window gtk)]
[gc (gdk_gc_new win)]
[gray #x8000])
(when gc
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray))
(let ([r (GdkEventExpose-area event)])
(gdk_draw_rectangle win gc #t
(GdkRectangle-x r)
(GdkRectangle-y r)
(GdkRectangle-width r)
(GdkRectangle-height r)))
(gdk_gc_unref gc)))))
(define-signal-handler connect-value-changed-h "value-changed"
(_fun _GtkWidget -> _void)
(lambda (gtk)

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

@ -18,11 +18,23 @@
(provide
(protect-out dc%
do-backing-flush
x11-bitmap%))
x11-bitmap%
gdk_gc_new
gdk_gc_unref
gdk_gc_set_rgb_fg_color
gdk_draw_rectangle))
(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
#:wrap (allocator cairo_destroy))
(define-gdk gdk_gc_unref (_fun _pointer -> _void)
#:wrap (deallocator))
(define-gdk gdk_gc_new (_fun _GdkWindow -> _pointer)
#:wrap (allocator gdk_gc_unref))
(define-gdk gdk_gc_set_rgb_fg_color (_fun _pointer _GdkColor-pointer -> _void))
(define-gdk gdk_draw_rectangle (_fun _GdkWindow _pointer _gboolean _int _int _int _int -> _void))
(define-cstruct _GdkVisual-rec ([type-instance _pointer]
[ref_count _uint]
[qdata _pointer]

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

@ -6,7 +6,8 @@
"window.rkt"
"utils.rkt"
"types.rkt"
"const.rkt")
"const.rkt"
"dc.rkt")
(provide
(protect-out panel%
@ -14,13 +15,35 @@
panel-container-mixin
gtk_fixed_new
gtk_fixed_move))
gtk_fixed_move
gtk_container_set_border_width
connect-expose-border))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_event_box_new (_fun -> _GtkWidget))
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_container_set_border_width (_fun _GtkWidget _int -> _void))
(define-signal-handler connect-expose-border "expose-event"
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let* ([win (widget-window gtk)]
[gc (gdk_gc_new win)]
[gray #x8000])
(when gc
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray))
(let ([a (widget-allocation gtk)])
(gdk_draw_rectangle win gc #f
0
0
(sub1 (GtkAllocation-width a))
(sub1 (GtkAllocation-height a))))
(gdk_gc_unref gc)))
#f))
(define (panel-mixin %)
(class %
@ -81,15 +104,24 @@
style
label)
(inherit get-gtk set-auto-size set-size)
(inherit get-gtk set-auto-size set-size
adjust-client-delta)
(define gtk (as-gtk-allocation (gtk_event_box_new)))
(define border-gtk (atomically
(and (memq 'border style)
(let ([border-gtk (gtk_fixed_new)])
(gtk_container_add gtk border-gtk)
(gtk_container_set_border_width border-gtk 1)
(connect-expose-border border-gtk)
(gtk_widget_show border-gtk)
border-gtk))))
(define client-gtk (atomically
(let ([client (gtk_fixed_new)])
(gtk_container_add gtk client)
(gtk_container_add (or border-gtk gtk) client)
(gtk_widget_show client)
client)))
(define/override (get-client-gtk) client-gtk)
(super-new [parent parent]
@ -98,7 +130,9 @@
[no-show? (memq 'deleted style)])
;; Start with a minimum size:
(set-size 0 0 1 1)
(set-size 0 0 (if border-gtk 3 1) (if border-gtk 3 1))
(when border-gtk
(adjust-client-delta 2 2))
(connect-key-and-mouse gtk)
(gtk_widget_add_events gtk (bitwise-ior GDK_BUTTON_PRESS_MASK

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

@ -41,6 +41,7 @@
(struct-out GtkAllocation) _GtkAllocation-pointer
widget-window
widget-allocation
the-accelerator-group
gtk_window_add_accel_group
@ -104,6 +105,9 @@
(define (widget-window gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define (widget-allocation gtk)
(GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void))
(define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void))
(define-gtk gtk_drag_dest_unset (_fun _GtkWidget -> _void))

11
collects/mred/private/wx/win32/panel.rkt
View File

@ -94,8 +94,6 @@
(define/public (set-item-cursor x y) (void))))
(define WS_EX_STATICEDGE #x00020000)
(define panel%
(class (panel-mixin window%)
(init parent
@ -105,14 +103,15 @@
(super-new [parent parent]
[hwnd
(CreateWindowExW (if (memq 'border style)
WS_EX_STATICEDGE
0)
(CreateWindowExW 0
(if (send parent is-frame?)
"PLTPanel"
"PLTTabPanel")
#f
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
(if (memq 'border style)
WS_BORDER
0))
0 0 w h
(send parent get-content-hwnd)
#f