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

canvas scrollbars and borders

Browse Source 
original commit: 6cb07301c1747c12232f6563f13cd4ae0541ebda
This commit is contained in:
Matthew Flatt 2010-08-02 18:52:16 -06:00
parent e267680559
commit 44a8d8ce2b
7 changed files with 219 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -30,6 +30,7 @@
#:mixins (FocusResponder KeyMouseResponder)
[wx]
(-a _void (drawRect: [_NSRect r])
(unless (send wx reject-partial-update r)
(let ([bg (send wx get-canvas-background-for-clearing)])
(when bg
(let ([ctx (tell NSGraphicsContext currentContext)])
@ -46,7 +47,7 @@
(tellv ctx restoreGraphicsState))))
(send wx queue-paint)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event))
(post-dummy-event)))
(-a _void (viewWillMoveToWindow: [_id w])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc)))))
@ -55,6 +56,37 @@
(-a _void (onVScroll: [_id scroller])
(when wx (send wx do-scroll 'vertical scroller))))
(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)])
(CGContextSetRGBFillColor cg 0 0 0 1.0)
(CGContextFillRect cg r))
(tellv ctx restoreGraphicsState))))
(define-cocoa NSSetFocusRingStyle (_fun _int -> _void))
(define-cocoa NSRectFill (_fun _NSRect -> _void))
(define-objc-class FocusView NSView
[on?]
(-a _void (setFocusState: [_BOOL is-on?])
(set! on? is-on?))
(-a _void (drawRect: [_NSRect r])
(when on?
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(NSSetFocusRingStyle 0)
(let ([r (tell #:type _NSRect self bounds)])
(NSRectFill (make-NSRect (make-NSPoint
(+ (NSPoint-x (NSRect-origin r)) 2)
(+ (NSPoint-y (NSRect-origin r)) 2))
(make-NSSize
(- (NSSize-width (NSRect-size r)) 4)
(- (NSSize-height (NSRect-size r)) 4)))))
(tellv ctx restoreGraphicsState)))))
(define-objc-class MyComboBox NSComboBox
#:mixins (FocusResponder KeyMouseResponder)
#:protocols (NSComboBoxDelegate)
@ -104,15 +136,27 @@
is-shown-to-root?
move get-x get-y
on-size
register-as-child)
register-as-child
get-size get-position)
(define vscroll-ok? (and (memq 'vscroll style) #t))
(define vscroll? vscroll-ok?)
(define hscroll-ok? (and (memq 'hscroll style) #t))
(define hscroll? hscroll-ok?)
(define-values (x-margin y-margin)
(cond
[(memq 'control-border style) (values 3 3)]
[(memq 'border style) (values 1 1)]
[else (values 0 0)]))
(define canvas-style style)
(define/override (focus-is-on on?)
(when (memq 'control-border canvas-style)
(tellv cocoa setFocusState: #:type _BOOL on?)
(tellv cocoa setNeedsDisplay: #:type _BOOL #t)))
(define is-visible? #f)
;; Avoid multiple queued paints:
@ -148,16 +192,22 @@
[parent parent]
[cocoa
(as-objc-allocation
(tell (tell NSView alloc)
(tell (tell (cond
[(memq 'control-border style) FocusView]
[(memq 'border style) FrameView]
[else NSView])
alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint x y)
(make-NSSize w h))))]
(make-NSSize (max w (* 2 x-margin))
(max h (* 2 y-margin))))))]
[no-show? (memq 'deleted style)])
(define cocoa (get-cocoa))
(define content-cocoa
(let ([r (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h))])
(make-NSSize (max 0 (- w (* 2 x-margin)))
(max 0 (- h (* 2 y-margin)))))])
(as-objc-allocation
(tell (tell (if is-combo? MyComboBox MyView) alloc)
initWithFrame: #:type _NSRect r))))
@ -213,30 +263,33 @@
(when tr
(tellv content-cocoa removeTrackingRect: #:type _NSInteger tr)
(set! tr #f))
(let ([sz (make-NSSize (- w (if vscroll? scroll-width 0))
(- h (if hscroll? scroll-width 0)))]
[pos (make-NSPoint 0 (if hscroll? scroll-width 0))])
(let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin)
(- h (if hscroll? scroll-width 0) y-margin y-margin))]
[pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))])
(tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz))
(set! tr (tell #:type _NSInteger
content-cocoa
addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) sz)
addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz)
owner: content-cocoa
userData: #f
assumeInside: #:type _BOOL #f)))
(when v-scroller
(tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect
(make-NSRect
(make-NSPoint (- w scroll-width)
(if hscroll?
(make-NSPoint (- w scroll-width x-margin)
(+ (if hscroll?
scroll-width
0))
0)
y-margin))
(make-NSSize scroll-width
(- h (if hscroll? scroll-width 0))))))
(max 0 (- h (if hscroll? scroll-width 0)
x-margin x-margin))))))
(when h-scroller
(tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect
(make-NSRect
(make-NSPoint 0 0)
(make-NSSize (- w (if vscroll? scroll-width 0))
(make-NSPoint x-margin y-margin)
(make-NSSize (max 0 (- w (if vscroll? scroll-width 0)
x-margin x-margin))
scroll-width))))
(fix-dc)
(on-size 0 0))
@ -262,11 +315,10 @@
[(and vscroll? (not v?))
(tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)])
(set! vscroll? v?)
(let ([r (tell #:type _NSRect cocoa frame)])
(do-set-size (NSPoint-x (NSRect-origin r))
(NSPoint-y (NSRect-origin r))
(NSSize-width (NSRect-size r))
(NSSize-height (NSRect-size r)))))))
(let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)])
(get-position x y)
(get-size w h)
(do-set-size (unbox x) (unbox y) (unbox w) (unbox h))))))
(define/public (set-scrollbars h-step v-step
h-len v-len
@ -309,12 +361,14 @@
(as-objc-allocation
(tell (tell NSScroller alloc) initWithFrame:
#:type _NSRect (make-NSRect
(make-NSPoint (- w scroll-width)
(if hscroll?
(make-NSPoint (- w scroll-width x-margin)
(+ (if hscroll?
scroll-width
0))
0)
y-margin))
(make-NSSize scroll-width
(max (- h (if hscroll? scroll-width 0))
(max (- h (if hscroll? scroll-width 0)
y-margin y-margin)
(+ scroll-width 10))))))
1
1)))
@ -324,8 +378,9 @@
(as-objc-allocation
(tell (tell NSScroller alloc) initWithFrame:
#:type _NSRect (make-NSRect
(make-NSPoint 0 0)
(make-NSSize (max (- w (if vscroll? scroll-width 0))
(make-NSPoint x-margin y-margin)
(make-NSSize (max (- w (if vscroll? scroll-width 0)
x-margin x-margin)
(+ scroll-width 10))
scroll-width))))
1
@ -401,6 +456,25 @@
(not (memq 'no-autoclear canvas-style))
bg-col)))
(define/public (reject-partial-update r)
;; Called in the event-pump thread.
;; A transparent canvas cannot handle a partial update.
(and (or
;; Multiple clipping rects?
(let ([i (malloc _NSInteger)]
[r (malloc 'atomic _pointer)])
(tellv content-cocoa getRectsBeingDrawn: #:type _pointer r
count: #:type _pointer i)
((ptr-ref i _NSInteger) . > . 1))
;; Single clipping not whole area?
(let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))]
[s2 (NSRect-size r)])
(or ((NSSize-width s2) . < . (NSSize-width s1))
((NSSize-height s2) . < . (NSSize-height s1)))))
(begin
(queue-window-event this (lambda () (refresh)))
#t)))
(define/public (do-scroll direction scroller)
;; Called from the Cocoa handler thread
(let ([part (tell #:type _int scroller hitPart)])

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

@ -28,14 +28,18 @@
#t]
[-a _BOOL (becomeFirstResponder)
(and (super-tell becomeFirstResponder)
(begin
(send wx focus-is-on #t)
(queue-window-event wx (lambda ()
(send wx on-set-focus)))
#t)]
#t))]
[-a _BOOL (resignFirstResponder)
(and (super-tell resignFirstResponder)
(begin
(send wx focus-is-on #f)
(queue-window-event wx (lambda ()
(send wx on-kill-focus)))
#t)])
#t))])
(define-objc-mixin (KeyMouseResponder Superclass)
[wx]
@ -169,6 +173,8 @@
(unless no-show?
(show #t))
(define/public (focus-is-on on?) (void))
(define/public (get-cocoa) cocoa)
(define/public (get-cocoa-content) cocoa)
(define/public (get-cocoa-window) (send parent get-cocoa-window))

3
collects/mred/private/wx/common/cursor.rkt
View File

@ -15,7 +15,8 @@
(case-args
args
[([(symbol-in arrow bullseye cross hand ibeam watch blank
size-n/s size-e/w size-ne/sw size-nw/se)
size-n/s size-e/w size-ne/sw size-nw/se
arrow+watch)
sym])
(or (hash-ref standards sym #f)
(let ([c (new cursor-driver%)])

8
collects/mred/private/wx/common/freeze.rkt
View File

@ -63,10 +63,12 @@
'("\n")))))
;; FIXME: waiting 200msec is not a good enough rule.
(define (constrained-reply es thunk default [should-give-up?
(define (constrained-reply es thunk default
[should-give-up?
(let ([now (current-inexact-milliseconds)])
(lambda ()
((current-inexact-milliseconds) . > . (+ now 200))))])
((current-inexact-milliseconds) . > . (+ now 200))))]
#:fail-result [fail-result default])
(let ([b (freezer-box)])
(cond
[(not b)
@ -76,7 +78,7 @@
#;
(internal-error (format "constrained-reply not within an unfreeze point for ~s"
thunk))
default]
fail-result]
[(not (eq? (current-thread) (eventspace-handler-thread es)))
(internal-error "wrong eventspace for constrained event handling\n")
default]

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

@ -43,6 +43,8 @@
(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)
@ -79,16 +81,32 @@
(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
(define (handle-expose gtk event)
(define-signal-handler connect-expose "expose-event"
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(let ([gc (send wx get-canvas-background-for-clearing)])
(when gc
(gdk_draw_rectangle (g_object_get_window gtk) gc #t
0 0 32000 32000)))
(send wx queue-paint))
#t)
(define handle_expose
(function-ptr handle-expose (_fun #:atomic? #t _GtkWidget _GdkEventExpose -> _gboolean)))
#t))
(define-signal-handler connect-expose-border "expose-event"
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let* ([win (g_object_get_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 (handle-value-changed-h gtk ignored)
(let ([wx (gtk->wx gtk)])
@ -118,6 +136,10 @@
on-size register-as-child get-top-win)
(define is-combo? (memq 'combo style))
(define has-border? (or (memq 'border style)
(memq 'control-border style)))
(define margin (if has-border? 1 0))
(define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box)
(cond
@ -133,6 +155,8 @@
[hscroll (gtk_hscrollbar_new hadj)]
[vscroll (gtk_vscrollbar_new vadj)]
[resize-box (gtk_drawing_area_new)])
(when has-border?
(gtk_container_set_border_width h margin))
(gtk_box_pack_start h v #t #t 0)
(gtk_box_pack_start v client-gtk #t #t 0)
(gtk_box_pack_start h v2 #f #f 0)
@ -148,11 +172,27 @@
(gtk_widget_show h2)
(gtk_widget_show resize-box)
(gtk_widget_show client-gtk)
(values client-gtk h hadj vadj h2 v2 resize-box)))]
(unless (memq 'hscroll style)
(gtk_widget_hide hscroll)
(gtk_widget_hide resize-box))
(unless (memq 'vscroll style)
(gtk_widget_hide v2))
(values client-gtk h hadj vadj
(and (memq 'hscroll style) h2)
(and (memq 'vscroll style) v2)
(and (memq 'hscroll style) (memq 'vscroll style) resize-box))))]
[is-combo?
(let* ([gtk (gtk_combo_box_entry_new_text)]
[orig-entry (gtk_bin_get_child gtk)])
(values orig-entry gtk #f #f #f #f #f))]
[has-border?
(let ([client-gtk (gtk_drawing_area_new)]
[h (gtk_hbox_new #f 0)])
(gtk_box_pack_start h client-gtk #t #t 0)
(gtk_container_set_border_width h margin)
(connect-expose-border h)
(gtk_widget_show client-gtk)
(values client-gtk h #f #f #f #f #f))]
[else
(let ([client-gtk (gtk_drawing_area_new)])
(values client-gtk client-gtk #f #f #f #f #f))]))
@ -192,7 +232,7 @@
(GtkRequisition-height r)
(GtkRequisition-height r))))
(g_signal_connect client-gtk "expose-event" handle_expose)
(connect-expose client-gtk)
(connect-key-and-mouse client-gtk)
(connect-focus client-gtk)
(gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
@ -217,10 +257,8 @@
(define/override (get-client-gtk) client-gtk)
(define/override (handles-events?) #t)
;; For the moment, the client area always starts at the
;; control area's top left
(define/override (get-client-delta)
(values 0 0))
(values margin margin))
;; Avoid multiple queued paints:
(define paint-queued? #f)
@ -272,7 +310,14 @@
(when vscroll-gtk
(if v?
(gtk_widget_show vscroll-gtk)
(gtk_widget_hide vscroll-gtk))))
(gtk_widget_hide vscroll-gtk)))
(when (and hscroll-gtk vscroll-gtk)
(cond
[(and v? h?)
(gtk_widget_show resize-box)]
[(and v? (not h?))
;; remove corner
(gtk_widget_hide resize-box)])))
(define/public (set-scrollbars h-step v-step
h-len v-len
@ -369,4 +414,5 @@
(def/public-unimplemented view-start)
(define/public (set-resize-corner on?) (void))
(def/public-unimplemented get-virtual-size)))
(define/public (get-virtual-size xb yb) (set-box! xb 10) (set-box! yb 10))))

19
collects/mred/private/wx/gtk/types.rkt
View File

@ -5,7 +5,6 @@
(provide _GdkWindow
_GtkWidget _GtkWindow
_gpointer
_GdkEventExpose
_GType
_fnpointer
@ -21,7 +20,10 @@
_GdkEventCrossing _GdkEventCrossing-pointer
(struct-out GdkEventCrossing)
_GdkEventConfigure _GdkEventConfigure-pointer
(struct-out GdkEventConfigure))
(struct-out GdkEventConfigure)
_GdkEventExpose _GdkEventExpose-pointer
(struct-out GdkEventExpose)
(struct-out GdkRectangle))
(define _GType _long)
@ -31,7 +33,6 @@
(define _GtkWindow _GtkWidget)
(define _gpointer _GtkWidget)
(define _GdkEventExpose (_cpointer 'GdkEventExpose))
(define _GdkDevice (_cpointer 'GdkDevice))
@ -99,3 +100,15 @@
[y _int]
[width _int]
[height _int]))
(define-cstruct _GdkRectangle ([x _int]
[y _int]
[width _int]
[height _int]))
(define-cstruct _GdkEventExpose ([type _GdkEventType]
[window _GdkWindow]
[send_event _byte]
[area _GdkRectangle]
[region _pointer]
[count _int]))

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

@ -75,8 +75,8 @@
(define-ffi-definer define-gdk gdk-lib)
(define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib)
(define-gobj g_object_ref (_fun _GtkWidget -> _void))
(define-gobj g_object_unref (_fun _GtkWidget -> _void))
(define-gobj g_object_ref (_fun _pointer -> _void))
(define-gobj g_object_unref (_fun _pointer -> _void))
(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void))
(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))