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

svn: r11408

Browse Source
This commit is contained in:
Robby Findler 2008-08-25 02:21:29 +00:00
parent e58bf78f04
commit 6a2b6a10be
1 changed files with 19 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/drscheme/private/first-line-text.ss
View File

@ -66,20 +66,24 @@ The on-event method isnt' working right yet.
(send (send this get-canvas) refresh)))
(define/override (on-event event)
(let ([y (send event get-y)]
[h (fetch-first-line-height)])
(cond
[(and (< y h)
(not (or (send event moving?)
(send event leaving?)
(send event entering?)))
(let ([admin (get-admin)])
(and admin
(begin (send admin get-view #f by #f #f #f)
(= (unbox by) 0)))))
(scroll-to #f (send event get-x) 0 0 0 #f)]
[else
(super on-event event)])))
(cond
[(or (send event moving?)
(send event leaving?)
(send event entering?))
(super on-event event)]
[else
(let ([y (send event get-y)]
[h (fetch-first-line-height)]
[admin (get-admin)])
(unless admin (send admin get-view #f by #f #f #f))
(cond
[(and (< y h)
admin
(not (= (unbox by) 0)))
(send admin scroll-to (send event get-x) 0 0 0 #t)
(super on-event event)]
[else
(super on-event event)]))]))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
@ -143,6 +147,7 @@ The on-event method isnt' working right yet.
(super-new)))
#;
(begin
(define f (new frame% [label ""] [width 200] [height 200]))
(define t (new (editor:standard-style-list-mixin (first-line-text-mixin text%))))