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

cocoa: fix list-box scrolling

Browse Source 
Closes PR 11948
This commit is contained in:
Matthew Flatt 2011-08-04 07:38:10 -06:00
parent 84b9cf6b90
commit 1bc8978ce8
2 changed files with 19 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -187,17 +187,19 @@
[else (cons i (loop (tell #:type _NSInteger v [else (cons i (loop (tell #:type _NSInteger v
indexGreaterThanIndex: #:type _NSInteger i)))]))))))) indexGreaterThanIndex: #:type _NSInteger i)))])))))))
(define/private (visible-range)
(tell #:type _NSRange content-cocoa
rowsInRect: #:type _NSRect (tell #:type _NSRect cocoa documentVisibleRect)))
(define/public (get-first-item)
(NSRange-location (visible-range)))
(define/public (number-of-visible-items) (define/public (number-of-visible-items)
(NSRange-length (visible-range))) (define doc (tell #:type _NSRect cocoa documentVisibleRect))
(define h (tell #:type _CGFloat content-cocoa rowHeight))
(max 1 (inexact->exact (floor (/ (NSSize-height (NSRect-size doc)) h)))))
(define/public (get-first-item)
(define doc (tell #:type _NSRect cocoa documentVisibleRect))
(NSRange-location (tell #:type _NSRange content-cocoa rowsInRect: #:type _NSRect doc)))
(define/public (set-first-visible-item i) (define/public (set-first-visible-item i)
;; FIXME: visble doesn't mean at top: (define num-vis (number-of-visible-items))
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger i)) (define start (max 0 (min i (- count num-vis))))
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger start)
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger (+ start (sub1 num-vis))))
(define/private (replace items i s) (define/private (replace items i s)
(append (take items i) (append (take items i)

8
collects/mred/private/wxlitem.rkt
View File

@ -124,7 +124,8 @@
(class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font (class100 (make-control% wx:list-box% 0 0 #t #t) (parent cb label kind x y w h choices style font
label-font columns column-order) label-font columns column-order)
(inherit get-first-item (inherit get-first-item
set-first-visible-item) set-first-visible-item
number-of-visible-items)
(private (private
[scroll (lambda (dir) [scroll (lambda (dir)
(unless list-box-wheel-step (unless list-box-wheel-step
@ -136,7 +137,7 @@
(set! list-box-wheel-step 3))) (set! list-box-wheel-step 3)))
(let ([top (get-first-item)]) (let ([top (get-first-item)])
(set-first-visible-item (set-first-visible-item
(max 0 (+ top (* list-box-wheel-step dir))))))]) (max 0 (+ top (* (min list-box-wheel-step (number-of-visible-items)) dir))))))])
(override (override
[handles-key-code (lambda (x alpha? meta?) [handles-key-code (lambda (x alpha? meta?)
(case x (case x
@ -144,10 +145,11 @@
[else (and alpha? (not meta?))]))] [else (and alpha? (not meta?))]))]
[pre-on-char (lambda (w e) [pre-on-char (lambda (w e)
(or (super pre-on-char w e) (or (super pre-on-char w e)
(and (not (eq? (system-type) 'macosx)) ; scrolling is built into NSListView
(case (send e get-key-code) (case (send e get-key-code)
[(wheel-up) (scroll -1) #t] [(wheel-up) (scroll -1) #t]
[(wheel-down) (scroll 1) #t] [(wheel-down) (scroll 1) #t]
[else #f])))]) [else #f]))))])
(sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font
label-font columns column-order))))) label-font columns column-order)))))