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

move gtk+cocoa canvas autoscroll support to common mixin

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-10 08:23:58 -06:00
parent 0f754f2878
commit 682355def4
3 changed files with 158 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -178,7 +178,7 @@
(define canvas%
(canvas-mixin
(class window%
(class (canvas-autoscroll-mixin window%)
(init parent
x y w h
style
@ -195,17 +195,16 @@
register-as-child
get-size get-position
set-focus
client-to-screen)
client-to-screen
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll)
(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 auto-scroll? #f)
(define virtual-height #f)
(define virtual-width #f)
(define wants-focus? (not (memq 'no-focus style)))
(define is-combo? (memq 'combo style))
(define has-control-border? (and (not is-combo?)
@ -309,8 +308,8 @@
(when (dc . is-a? . dc%)
(send dc reset-backing-retained)
(send dc set-auto-scroll
(if auto-scroll? (scroll-pos h-scroller) 0)
(if auto-scroll? (scroll-pos v-scroller) 0)))
(if (is-auto-scroll?) (scroll-pos h-scroller) 0)
(if (is-auto-scroll?) (scroll-pos v-scroller) 0)))
(when refresh? (refresh)))
(define/override (get-client-size xb yb)
@ -380,7 +379,7 @@
(is-shown-to-root?))
(atomically (resume-all-reg-blits)))
(fix-dc)
(when auto-scroll?
(when (is-auto-scroll?)
(reset-auto-scroll 0 0))
(on-size 0 0))
@ -406,69 +405,25 @@
(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
h-page v-page
h-pos v-pos
auto?)
(cond
[auto?
(set! auto-scroll? #t)
(set! virtual-width (and (positive? h-len) h-len))
(set! virtual-height (and (positive? v-len) v-len))
(reset-auto-scroll h-pos v-pos)
(refresh-for-autoscroll)]
[else
(let ([a? auto-scroll?])
(set! auto-scroll? #f)
(when a? (fix-dc))) ; disable scroll offsets
(scroll-range h-scroller h-len)
(scroll-page h-scroller h-page)
(scroll-pos h-scroller h-pos)
(when h-scroller
(tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
(scroll-range v-scroller v-len)
(scroll-page v-scroller v-page)
(scroll-pos v-scroller v-pos)
(when v-scroller
(tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))
(set! virtual-width #f)
(set! virtual-height #f)]))
(define/override (do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)
(scroll-range h-scroller h-len)
(scroll-page h-scroller h-page)
(scroll-pos h-scroller h-pos)
(when h-scroller
(tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
(scroll-range v-scroller v-len)
(scroll-page v-scroller v-page)
(scroll-pos v-scroller v-pos)
(when v-scroller
(tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
(define/private (reset-auto-scroll h-pos v-pos)
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
(let ([cw (unbox xb)]
[ch (unbox yb)])
(let ([h-len (if virtual-width
(max 0 (- virtual-width cw))
0)]
[v-len (if virtual-height
(max 0 (- virtual-height ch))
0)]
[h-page (if virtual-width
cw
0)]
[v-page (if virtual-height
ch
0)])
(scroll-range h-scroller h-len)
(scroll-page h-scroller h-page)
(scroll-pos h-scroller h-pos)
(when h-scroller
(tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len)))
(scroll-range v-scroller v-len)
(scroll-page v-scroller v-page)
(scroll-pos v-scroller v-pos)
(when v-scroller
(tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len)))))))
(define/override (reset-dc-for-autoscroll)
(fix-dc))
(define/private (refresh-for-autoscroll)
(fix-dc)
(refresh))
(define (update which scroll- v)
(define/private (update which scroll- v)
(if (eq? which 'vertical)
(scroll- v-scroller v)
(scroll- h-scroller v)))
@ -629,7 +584,7 @@
'thumb]
[else #f])])
(when kind
(if auto-scroll?
(if (is-auto-scroll?)
(refresh-for-autoscroll)
(on-scroll (new scroll-event%
[event-type kind]
@ -690,22 +645,15 @@
(define/public (scroll x y)
(when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller))))
(when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller))))
(when auto-scroll? (refresh-for-autoscroll)))
(when (is-auto-scroll?) (refresh-for-autoscroll)))
(def/public-unimplemented warp-pointer)
(define/public (view-start xb yb)
(if auto-scroll?
(begin
(set-box! xb (if virtual-width
(scroll-pos h-scroller)
0))
(set-box! yb (if virtual-height
(scroll-pos v-scroller)
0)))
(begin
(set-box! xb 0)
(set-box! yb 0))))
(define/override (get-virtual-h-pos)
(scroll-pos h-scroller))
(define/override (get-virtual-v-pos)
(scroll-pos v-scroller))
(define/public (set-resize-corner on?)
(void))
@ -721,11 +669,6 @@
(define/public (is-flipped?)
(tell #:type _BOOL (get-cocoa-content) isFlipped))
(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)))
(define blits null)
(define reg-blits null)

106
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -2,11 +2,115 @@
(require racket/class
"backing-dc.rkt")
(provide canvas-mixin)
(provide canvas-autoscroll-mixin
canvas-mixin)
;; Implements canvas autoscroll, applied *before* platform-specific canvas
;; methods:
(define (canvas-autoscroll-mixin %)
(class %
(super-new)
(inherit get-client-size
refresh)
(define auto-scroll? #f)
(define virtual-height #f)
(define virtual-width #f)
(define/public (is-auto-scroll?) auto-scroll?)
(define/public (get-virtual-height) virtual-height)
(define/public (get-virtual-width) virtual-width)
(define/public (set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos
auto?)
(cond
[auto?
(set! auto-scroll? #t)
(set! virtual-width (and (positive? h-len) h-len))
(set! virtual-height (and (positive? v-len) v-len))
(reset-auto-scroll h-pos v-pos)
(refresh-for-autoscroll)]
[else
(let ([a? auto-scroll?])
(set! auto-scroll? #f)
(set! virtual-width #f)
(set! virtual-height #f)
(when a? (reset-dc-for-autoscroll))) ; disable scroll offsets
(do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)]))
;; To be overridden:
(define/public (do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)
(void))
(define/public (reset-auto-scroll h-pos v-pos)
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
(let ([cw (unbox xb)]
[ch (unbox yb)])
(let ([h-len (if virtual-width
(max 0 (- virtual-width cw))
0)]
[v-len (if virtual-height
(max 0 (- virtual-height ch))
0)]
[h-page (if virtual-width
cw
0)]
[v-page (if virtual-height
ch
0)])
(do-set-scrollbars 1 1
h-len v-len
h-page v-page
h-pos v-pos)))))
;; To be overridden:
(define/public (reset-dc-for-autoscroll)
(void))
(define/public (refresh-for-autoscroll)
(reset-dc-for-autoscroll)
(refresh))
(define/public (view-start xb yb)
(if auto-scroll?
(begin
(set-box! xb (if virtual-width
(get-virtual-h-pos)
0))
(set-box! yb (if virtual-height
(get-virtual-v-pos)
0)))
(begin
(set-box! xb 0)
(set-box! yb 0))))
;; To be overridden:
(define/public (get-virtual-h-pos) 0)
(define/public (get-virtual-v-pos) 0)
(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)))))
;; Implements canvas refresh, applied *after* platform-specific canvas
;; methods:
(define (canvas-mixin %)
(class %
(super-new)
(inherit request-canvas-flush-delay
cancel-canvas-flush-delay
queue-canvas-refresh-event

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

@ -181,7 +181,7 @@
(define canvas%
(canvas-mixin
(class (client-size-mixin window%)
(class (canvas-autoscroll-mixin (client-size-mixin window%))
(init parent
x y w h
style
@ -191,7 +191,10 @@
(inherit get-gtk set-size get-size get-client-size
on-size get-top-win
set-auto-size
adjust-client-delta infer-client-delta)
adjust-client-delta infer-client-delta
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll)
(define is-combo? (memq 'combo style))
(define has-border? (or (memq 'border style)
@ -199,10 +202,6 @@
(define margin (if has-border? 1 0))
(define auto-scroll? #f)
(define virtual-height #f)
(define virtual-width #f)
(define-values (client-gtk gtk
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
combo-button-gtk
@ -386,10 +385,10 @@
(send dc reset-backing-retained)
(refresh)
(send dc set-auto-scroll
(if virtual-width
(if (get-virtual-width)
(gtk_adjustment_get_value hscroll-adj)
0)
(if virtual-height
(if (get-virtual-height)
(gtk_adjustment_get_value vscroll-adj)
0)))
@ -438,48 +437,15 @@
(gtk_adjustment_configure adj 0 0 1 1 1 1)
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page))))))
(define/public (set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos
auto?)
(let ([h-page (if (zero? h-len) 0 h-page)]
[v-page (if (zero? v-len) 0 v-page)])
(cond
[auto?
(set! auto-scroll? #t)
(set! virtual-width (and (positive? h-len) hscroll-gtk h-len))
(set! virtual-height (and (positive? v-len) vscroll-gtk v-len))
(reset-auto-scroll h-pos v-pos)
(refresh-for-autoscroll)]
[else
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)])))
(define/override (do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))
(define/private (reset-auto-scroll h-pos v-pos)
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
(let ([cw (unbox xb)]
[ch (unbox yb)])
(let ([h-len (if virtual-width
(max 0 (- virtual-width cw))
0)]
[v-len (if virtual-height
(max 0 (- virtual-height ch))
0)]
[h-page (if virtual-width
cw
0)]
[v-page (if virtual-height
ch
0)])
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)))))
(define/private (refresh-for-autoscroll)
(reset-dc)
(refresh))
(define/override (reset-dc-for-autoscroll)
(reset-dc))
(define/private (dispatch which proc [default (void)])
(if (eq? which 'vertical)
@ -559,7 +525,7 @@
(def/public-unimplemented set-background-to-gray)
(define/public (do-scroll direction)
(if auto-scroll?
(if (is-auto-scroll?)
(refresh-for-autoscroll)
(on-scroll (new scroll-event%
[event-type 'thumb]
@ -572,29 +538,16 @@
(lambda ()
(when hscroll-adj (gtk_adjustment_set_value hscroll-adj x))
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))))
(when auto-scroll? (refresh-for-autoscroll)))
(when (is-auto-scroll?) (refresh-for-autoscroll)))
(def/public-unimplemented warp-pointer)
(define/public (view-start xb yb)
(if auto-scroll?
(begin
(set-box! xb (if virtual-width
(gtk_adjustment_get_value hscroll-adj)
0))
(set-box! yb (if virtual-height
(gtk_adjustment_get_value vscroll-adj)
0)))
(begin
(set-box! xb 0)
(set-box! yb 0))))
(define/override (get-virtual-h-pos)
(gtk_adjustment_get_value hscroll-adj))
(define/override (get-virtual-v-pos)
(gtk_adjustment_get_value vscroll-adj))
(define/public (set-resize-corner on?) (void))
(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)))
(define reg-blits null)