3873064c80
A relatively late correction to refresh handling for El Capitan
(commit 9bf18505d5) causes a canvas to be refreshed too often
in some cases. Delay the refresh to restore the old timing
without the old bug.
1286 lines
48 KiB
Racket
1286 lines
48 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/file
|
|
"../syntax.rkt"
|
|
"editor.rkt"
|
|
"editor-admin.rkt"
|
|
"private.rkt"
|
|
racket/snip/private/prefs
|
|
racket/snip/private/private
|
|
(only-in "cycle.rkt" popup-menu%)
|
|
(only-in "../kernel.rkt" queue-refresh-event)
|
|
"wx.rkt")
|
|
|
|
(provide editor-canvas%)
|
|
|
|
;; FIXME: need contracts on public classes
|
|
|
|
(define (object/bool=? a b)
|
|
(and a b (object=? a b)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define simple-scroll%
|
|
(class object%
|
|
(define horizontal #f)
|
|
(define count 0)
|
|
(define page-step 0)
|
|
(define value 0)
|
|
|
|
(init canvas
|
|
style
|
|
length
|
|
steps-per-page
|
|
position)
|
|
|
|
(super-new)
|
|
|
|
(set! count length)
|
|
(set! page-step steps-per-page)
|
|
(set! value position)
|
|
|
|
(set! horizontal (and (memq 'horizontal style) #t))
|
|
(set-scroll length steps-per-page position)
|
|
|
|
(define/public (set-value position)
|
|
(set! value (max 0 (min count position))))
|
|
|
|
(define/public (set-scroll length steps-per-page position)
|
|
(when (length . > . -1)
|
|
(set! count length))
|
|
(when (steps-per-page . > . 0)
|
|
(set! page-step steps-per-page))
|
|
(when (position . > . -1)
|
|
(set! value position))
|
|
|
|
(when (value . < . 0)
|
|
(set! value 0))
|
|
(when (value . > . count)
|
|
(set! value count)))
|
|
|
|
(define/public (get-value)
|
|
value)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define update-cursor-timer%
|
|
(class timer%
|
|
(inherit start stop)
|
|
(init-field admin)
|
|
|
|
(super-new)
|
|
|
|
(define/override (notify)
|
|
(stop)
|
|
(when admin
|
|
(send admin clear-update-cursor-timer)
|
|
(send (send admin get-canvas) update-cursor-now)))
|
|
|
|
(define/public (cancel)
|
|
(set! admin #f))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define BLINK-DELAY 500)
|
|
|
|
(define blink-timer%
|
|
(class timer%
|
|
(inherit stop)
|
|
(init-field canvas)
|
|
|
|
(super-new)
|
|
|
|
(define/override (notify)
|
|
(when canvas
|
|
(if (send canvas is-shown-to-root?)
|
|
(send canvas blink-caret)
|
|
(kill))))
|
|
|
|
(define/public (kill)
|
|
(set! canvas #f)
|
|
(stop))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define AUTO-DRAG-DELAY 100)
|
|
|
|
(define auto-drag-timer%
|
|
(class timer%
|
|
(inherit start stop)
|
|
(init-field canvas event)
|
|
|
|
(super-new)
|
|
|
|
(start AUTO-DRAG-DELAY #t)
|
|
|
|
(define/override (notify)
|
|
(when canvas
|
|
(let ([e (make-object mouse-event% (send event get-event-type))])
|
|
(send e set-alt-down (send event get-alt-down))
|
|
(send e set-caps-down (send event get-caps-down))
|
|
(send e set-control-down (send event get-control-down))
|
|
(send e set-left-down (send event get-left-down))
|
|
(send e set-meta-down (send event get-meta-down))
|
|
(send e set-middle-down (send event get-middle-down))
|
|
(send e set-right-down (send event get-right-down))
|
|
(send e set-shift-down (send event get-shift-down))
|
|
(send e set-x (send event get-x))
|
|
(send e set-y (send event get-y))
|
|
(send e set-time-stamp
|
|
(+ (send e get-time-stamp) AUTO-DRAG-DELAY))
|
|
(send canvas on-event event))))
|
|
|
|
(define/public (kill)
|
|
(set! canvas #f)
|
|
(stop))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define default-wheel-amt
|
|
(let ([v (get-preference* 'GRacket:wheelStep)])
|
|
(if (exact-integer? v)
|
|
(max 3 (min 1000 v))
|
|
3)))
|
|
|
|
(define (INIT-SB style)
|
|
(append
|
|
(if (or (memq 'no-hscroll style)
|
|
(memq 'hide-hscroll style))
|
|
null
|
|
'(hscroll))
|
|
(if (or (memq 'no-vscroll style)
|
|
(memq 'hide-vscroll style))
|
|
null
|
|
'(vscroll))))
|
|
|
|
(define (memq? s l) (and (memq s l) #t))
|
|
|
|
(define (keep-style l s) (if (memq s l) (list s) null))
|
|
|
|
(defclass editor-canvas% canvas%
|
|
|
|
(inherit refresh get-canvas-background get-dc
|
|
get-client-size get-size set-cursor
|
|
get-scroll-pos set-scroll-pos
|
|
get-scroll-page set-scroll-page
|
|
get-scroll-range set-scroll-range
|
|
is-shown-to-root?
|
|
show-scrollbars
|
|
set-focus
|
|
begin-refresh-sequence
|
|
end-refresh-sequence)
|
|
|
|
(define blink-timer #f)
|
|
(define noloop? #f)
|
|
|
|
(define focuson? #f)
|
|
(define focusforcedon? #f)
|
|
(define/public (get-focusforcedon?) focusforcedon?)
|
|
(define lazy-refresh? #f)
|
|
(define need-refresh? #f)
|
|
|
|
(define auto-dragger #f)
|
|
|
|
(define custom-cursor #f)
|
|
(define custom-cursor-on? #f)
|
|
|
|
(define scroll-to-last? #f)
|
|
(define scroll-bottom-based? #f)
|
|
(define scroll-offset 0)
|
|
|
|
(define lastwidth -1)
|
|
(define lastheight -1)
|
|
|
|
(define last-x 0)
|
|
(define last-y 0)
|
|
|
|
(define bg-color #f)
|
|
|
|
(define wheel-amt default-wheel-amt)
|
|
(define xmargin 5)
|
|
(define ymargin 5)
|
|
|
|
(define/public (set-wheel-step v) (set! wheel-amt v))
|
|
(define/public (get-wheel-step) wheel-amt)
|
|
|
|
(set! noloop? #t)
|
|
(init parent x y width height
|
|
name style
|
|
[scrolls-per-page 100]
|
|
[editor #f]
|
|
[gl-config #f])
|
|
|
|
(super-make-object parent
|
|
x y width height
|
|
(append (keep-style style 'border)
|
|
(INIT-SB style)
|
|
(keep-style style 'invisible)
|
|
(if (memq 'transparent style)
|
|
'(transparent)
|
|
'(no-autoclear))
|
|
(keep-style style 'control-border)
|
|
(keep-style style 'combo)
|
|
(keep-style style 'resize-corner)
|
|
(keep-style style 'no-focus)
|
|
(keep-style style 'deleted))
|
|
name
|
|
gl-config)
|
|
|
|
(define given-h-scrolls-per-page scrolls-per-page)
|
|
|
|
(define allow-x-scroll? (not (memq 'no-hscroll style)))
|
|
(define allow-y-scroll? (not (memq 'no-vscroll style)))
|
|
|
|
(define fake-x-scroll? (or (not allow-x-scroll?)
|
|
(memq? 'hide-hscroll style)))
|
|
(define fake-y-scroll? (or (not allow-y-scroll?)
|
|
(memq? 'hide-vscroll style)))
|
|
|
|
(define auto-x? (and (not fake-x-scroll?)
|
|
(memq? 'auto-hscroll style)))
|
|
(define auto-y? (and (not fake-y-scroll?)
|
|
(memq? 'auto-vscroll style)))
|
|
|
|
(define xscroll-on? (and (not fake-x-scroll?) (not auto-x?)))
|
|
(define yscroll-on? (and (not fake-y-scroll?) (not auto-y?)))
|
|
|
|
(show-scrollbars xscroll-on? yscroll-on?)
|
|
(super set-scrollbars
|
|
1 1 ;; Windows fake-{x,y}-scroll => -1 instead of 1 !?
|
|
1 1 ;;
|
|
1 1 0 0 #f)
|
|
|
|
(define hscroll
|
|
(if fake-x-scroll?
|
|
(new simple-scroll%
|
|
[canvas this]
|
|
[style '(horizontal)]
|
|
[length 0]
|
|
[steps-per-page 1]
|
|
[position 0])
|
|
#f))
|
|
(define vscroll
|
|
(if fake-y-scroll?
|
|
(new simple-scroll%
|
|
[canvas this]
|
|
[style '(vertical)]
|
|
[length 0]
|
|
[steps-per-page 1]
|
|
[position 0])
|
|
#f))
|
|
|
|
(define scroll-width (if fake-x-scroll? 1 1)) ;; else used to be 0
|
|
(define scroll-height (if fake-y-scroll? 1 1))
|
|
|
|
(define hscrolls-per-page 1)
|
|
(define vscrolls-per-page 1)
|
|
(define hpixels-per-scroll 0)
|
|
|
|
(set! noloop? #f)
|
|
|
|
(define admin (new canvas-editor-admin%
|
|
[canvas this]))
|
|
(send admin adjust-std-flag)
|
|
|
|
(define media editor)
|
|
(when media (set-editor media))
|
|
|
|
;; FIXME: needed?
|
|
(define/public (~)
|
|
(when auto-dragger
|
|
(send auto-dragger kill)
|
|
(set! auto-dragger #f))
|
|
(when blink-timer
|
|
(send blink-timer kill)
|
|
(set! blink-timer #f))
|
|
(send admin set-canvas #f)
|
|
#|(super ~)|#)
|
|
|
|
(define/override (on-size)
|
|
(unless noloop?
|
|
(queue-refresh-event
|
|
(get-eventspace)
|
|
(lambda ()
|
|
(unless (and media
|
|
(send media get-printing))
|
|
(maybe-reset-size))))))
|
|
|
|
(define/private (maybe-reset-size)
|
|
(let-boxes ([w 0]
|
|
[h 0])
|
|
(get-size w h)
|
|
(unless (and (= w lastwidth)
|
|
(= h lastheight))
|
|
(begin-refresh-sequence)
|
|
(reset-size)
|
|
(end-refresh-sequence))))
|
|
|
|
(define/private (reset-size)
|
|
(reset-visual #f)
|
|
(refresh))
|
|
|
|
(define/public (set-x-margin x)
|
|
(unless (= x xmargin)
|
|
(set! xmargin x)
|
|
(reset-size)))
|
|
(define/public (set-y-margin y)
|
|
(unless (= y ymargin)
|
|
(set! ymargin y)
|
|
(reset-size)))
|
|
(define/public (get-x-margin) xmargin)
|
|
(define/public (get-y-margin) ymargin)
|
|
|
|
(define/override (set-canvas-background c)
|
|
(super set-canvas-background c)
|
|
(refresh))
|
|
|
|
(define-syntax-rule (using-admin body ...)
|
|
(let ([oldadmin (send media get-admin)])
|
|
(unless (eq? admin oldadmin)
|
|
(send media set-admin admin))
|
|
(begin0
|
|
(begin body ...)
|
|
(when media
|
|
(unless (eq? admin oldadmin)
|
|
;; FIXME: how do we know that this adminstrator
|
|
;; still wants the editor?
|
|
(send media set-admin oldadmin))))))
|
|
|
|
(define/private (get-eventspace)
|
|
(send (send this get-top-level) get-eventspace))
|
|
|
|
(define/private (on-focus focus?)
|
|
(unless (eq? focus? focuson?)
|
|
(set! focuson? focus?)
|
|
(when (and media
|
|
(not (send media get-printing)))
|
|
(using-admin
|
|
(when media
|
|
(send media own-caret focus?))))
|
|
(when focuson?
|
|
(unless blink-timer
|
|
(set! blink-timer (parameterize ([current-eventspace (get-eventspace)])
|
|
(new blink-timer% [canvas this]))))
|
|
(send blink-timer start BLINK-DELAY #t))))
|
|
|
|
(define/public (blink-caret)
|
|
(when focuson?
|
|
(when media
|
|
(using-admin
|
|
(when media
|
|
(send media blink-caret))))
|
|
(send blink-timer start BLINK-DELAY #t)))
|
|
|
|
(define/public (call-as-primary-owner thunk)
|
|
(if media
|
|
(using-admin
|
|
(thunk))
|
|
(thunk)))
|
|
|
|
(define/override (on-set-focus)
|
|
(super on-set-focus)
|
|
(on-focus #t))
|
|
(define/override (on-kill-focus)
|
|
(super on-kill-focus)
|
|
(on-focus #f))
|
|
|
|
(define/public (is-focus-on?) focuson?)
|
|
|
|
(define/public (force-display-focus on?)
|
|
(let ([old-on? focusforcedon?])
|
|
(set! focusforcedon? on?)
|
|
(send admin adjust-std-flag)
|
|
(when (not (equal? (or focuson? focusforcedon?)
|
|
(or focuson? old-on?)))
|
|
(refresh))))
|
|
|
|
(define/override (on-event event)
|
|
;; Turn off auto-dragger, if there is one
|
|
(when auto-dragger
|
|
(send auto-dragger kill)
|
|
(set! auto-dragger #f))
|
|
|
|
(let ([x (send event get-x)]
|
|
[y (send event get-y)])
|
|
(set! last-x x)
|
|
(set! last-y y)
|
|
|
|
#;
|
|
(when (and (eq? 'windows (system-type))
|
|
(not focuson?)
|
|
(send event button-down?))
|
|
(set-focus)
|
|
(on-focus #t))
|
|
|
|
(let ([out-of-client?
|
|
(let-boxes ([cw 0]
|
|
[ch 0])
|
|
(get-client-size cw ch)
|
|
(or (x . < . 0)
|
|
(y . < . 0)
|
|
(x . > . cw)
|
|
(y . > . ch)))])
|
|
|
|
(when (and media
|
|
(not (send media get-printing)))
|
|
(using-admin
|
|
(when media
|
|
(set-custom-cursor
|
|
(and (or (not out-of-client?)
|
|
(send event dragging?))
|
|
(send media adjust-cursor event))))
|
|
(when media
|
|
(send media on-event event))))
|
|
|
|
(when (send event dragging?)
|
|
(when out-of-client?
|
|
;; Dragging outside the canvas: auto-generate more events because the buffer
|
|
;; is probably scrolling. But make sure we're shown.
|
|
(when (is-shown-to-root?)
|
|
(set! auto-dragger (parameterize ([current-eventspace (get-eventspace)])
|
|
(new auto-drag-timer%
|
|
[canvas this]
|
|
[event event])))))))))
|
|
|
|
(define/private (update-cursor-now)
|
|
(when media
|
|
(let ([e (new mouse-event% [type 'motion])])
|
|
(send e set-x last-x)
|
|
(send e set-y last-y)
|
|
(send e set-timestamp 0)
|
|
|
|
(using-admin
|
|
(when media
|
|
(set-custom-cursor (send media adjust-cursor e)))))))
|
|
|
|
(define/public (popup-for-editor b m) #f)
|
|
|
|
(define/override (on-char event)
|
|
(let ([code (send event get-key-code)])
|
|
(case (and (positive? wheel-amt)
|
|
code)
|
|
[(wheel-up wheel-down)
|
|
(when (and allow-y-scroll?
|
|
(not fake-y-scroll?))
|
|
(let-boxes ([x 0]
|
|
[y 0])
|
|
(get-scroll x y)
|
|
(let ([old-y y]
|
|
[y (max (+ y
|
|
(* wheel-amt
|
|
(if (eq? code 'wheel-up)
|
|
-1
|
|
1)))
|
|
0)])
|
|
(do-scroll x y #t x old-y))))]
|
|
[(wheel-left wheel-right)
|
|
(when (and allow-x-scroll?
|
|
(not fake-x-scroll?))
|
|
(let-boxes ([x 0]
|
|
[y 0])
|
|
(get-scroll x y)
|
|
(let ([old-x x]
|
|
[x (max (+ x
|
|
(* wheel-amt
|
|
(if (eq? code 'wheel-left)
|
|
-1
|
|
1)))
|
|
0)])
|
|
(do-scroll x y #t old-x y))))]
|
|
[else
|
|
(when (and media (not (send media get-printing)))
|
|
(using-admin
|
|
(when media
|
|
(send media on-char event))))])))
|
|
|
|
(define/public (clear-margins)
|
|
;; This method is called by `on-paint' in `editor-canvas%'
|
|
;; before it calls the `on-paint' in `canvas%'. It's
|
|
;; essentially a compromise between autoclear mode and
|
|
;; no-autoclear mode.
|
|
|
|
(when (or (positive? xmargin)
|
|
(positive? ymargin))
|
|
(let ([bg (get-canvas-background)])
|
|
(when bg
|
|
(let ([cw (box 0)]
|
|
[ch (box 0)]
|
|
[b (send the-brush-list find-or-create-brush bg 'solid)]
|
|
[p (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)]
|
|
[dc (get-dc)])
|
|
(get-client-size cw ch)
|
|
(let ([ob (send dc get-brush)]
|
|
[op (send dc get-pen)]
|
|
[cw (unbox cw)]
|
|
[ch (unbox ch)])
|
|
(send dc set-brush b)
|
|
(send dc set-pen p)
|
|
|
|
(send dc draw-rectangle 0 0 xmargin ch)
|
|
(send dc draw-rectangle (- cw xmargin) 0 cw ch)
|
|
(send dc draw-rectangle 0 0 cw ymargin)
|
|
(send dc draw-rectangle 0 (- ch ymargin) cw ch)
|
|
|
|
(send dc set-brush ob)
|
|
(send dc set-pen op)))))))
|
|
|
|
(define/override (on-paint)
|
|
(set! need-refresh? #f)
|
|
(if media
|
|
(when (not (send media get-printing))
|
|
(redraw 'view 'view 'view 'view #f))
|
|
(let ([bg (get-canvas-background)])
|
|
(when bg
|
|
(let ([adc (get-dc)])
|
|
(send adc set-background bg)
|
|
(send adc clear)))))
|
|
(super on-paint))
|
|
|
|
(define/public (repaint)
|
|
(unless need-refresh?
|
|
(if (or lazy-refresh? (not (get-canvas-background)))
|
|
(begin
|
|
(set! need-refresh? #t)
|
|
(refresh))
|
|
(on-paint))))
|
|
|
|
(define/private (paint-scrolls) (void))
|
|
|
|
(define/public (set-lazy-refresh on?)
|
|
(set! lazy-refresh? on?)
|
|
(when (and (not on?)
|
|
need-refresh?)
|
|
(on-paint)))
|
|
|
|
(define/public (get-lazy-refresh) lazy-refresh?)
|
|
|
|
(define/public (set-custom-cursor cursor)
|
|
(if (not cursor)
|
|
(no-custom-cursor)
|
|
(begin
|
|
(set! custom-cursor-on? #t)
|
|
(set! custom-cursor cursor)
|
|
(set-cursor custom-cursor))))
|
|
|
|
(define arrow #f)
|
|
(define/public (no-custom-cursor)
|
|
(when (not arrow)
|
|
(set! arrow (make-object cursor% 'arrow)))
|
|
(when custom-cursor-on?
|
|
(set! custom-cursor-on? #f)
|
|
(set-cursor arrow)))
|
|
|
|
|
|
(define/public (get-dc-and-offset fx fy)
|
|
(when (or fx fy)
|
|
(let-boxes ([x 0]
|
|
[y 0])
|
|
(get-scroll x y)
|
|
(convert-scroll-to-location x y fx fy)))
|
|
(get-dc))
|
|
|
|
(define/private (convert-scroll-to-location x y fx fy)
|
|
(when fx
|
|
(set-box! fx (- (* x hpixels-per-scroll) xmargin)))
|
|
(when fy
|
|
(if (and media
|
|
(or (positive? y)
|
|
scroll-bottom-based?))
|
|
(let ([v (- (if (send media locked-for-read?)
|
|
0.0
|
|
(send media scroll-line-location (+ y scroll-offset)))
|
|
ymargin)])
|
|
(set-box! fy v)
|
|
(when (and scroll-bottom-based?
|
|
(or (positive? scroll-height)
|
|
scroll-to-last?))
|
|
(let-boxes ([w 0] [h 0])
|
|
(get-client-size w h)
|
|
(let ([h (max (- h (* 2 ymargin))
|
|
0)])
|
|
(set-box! fy (- (unbox fy) h))))))
|
|
(set-box! fy (- ymargin)))))
|
|
|
|
(define/public (get-view fx fy fw fh [unused-full? #f])
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(get-client-size w h)
|
|
(get-dc-and-offset fx fy)
|
|
(when fx
|
|
(set-box! fx (+ (unbox fx) xmargin)))
|
|
(when fy
|
|
(set-box! fy (+ (unbox fy) ymargin)))
|
|
(when fh
|
|
(set-box! fh (max 0 (- (unbox h) (* 2 ymargin)))))
|
|
(when fw
|
|
(set-box! fw (max 0 (- (unbox w) (* 2 xmargin)))))))
|
|
|
|
(define/public (redraw localx localy fw fh clear?)
|
|
(when (and media
|
|
(not (send media get-printing)))
|
|
(begin-refresh-sequence)
|
|
(let-values ([(localx localy fw fh)
|
|
(if (eq? localx 'view)
|
|
(let-boxes ([x 0][y 0][w 0][h 0])
|
|
(get-view x y w h)
|
|
(values x y w h))
|
|
(values localx localy fw fh))])
|
|
(when clear?
|
|
(let ([bg (get-canvas-background)])
|
|
(when bg
|
|
(let* ([dx (box 0)]
|
|
[dy (box 0)]
|
|
[adc (get-dc-and-offset dx dy)])
|
|
(let ([b (send adc get-brush)]
|
|
[p (send adc get-pen)])
|
|
(send adc set-brush bg 'solid)
|
|
(send adc set-pen bg 1 'transparent)
|
|
(send adc draw-rectangle (- localx (unbox dx)) (- localy (unbox dy)) fw fh)
|
|
(send adc set-brush b)
|
|
(send adc set-pen p))))))
|
|
(let ([x (box 0)]
|
|
[y (box 0)]
|
|
[w (box 0)]
|
|
[h (box 0)])
|
|
(get-view x y w h)
|
|
(let ([x (unbox x)]
|
|
[y (unbox y)]
|
|
[w (unbox w)]
|
|
[h (unbox h)])
|
|
(let ([right (+ x w)]
|
|
[bottom (+ y h)])
|
|
(let ([x (max x localx)]
|
|
[y (max y localy)]
|
|
[right (min right (+ localx fw))]
|
|
[bottom (min bottom (+ localy fh))])
|
|
(let ([w (max 0 (- right x))]
|
|
[h (max 0 (- bottom y))])
|
|
(when (or (positive? w)
|
|
(positive? h))
|
|
(using-admin
|
|
(when media
|
|
(send media refresh
|
|
x y w h
|
|
(if (or focuson? focusforcedon?)
|
|
'show-caret
|
|
'show-inactive-caret)
|
|
(get-canvas-background)))))))))))
|
|
(end-refresh-sequence)))
|
|
|
|
|
|
(def/public (scroll-to [real? localx] [real? localy] [real? fw] [real? fh] [any? refresh?]
|
|
[(symbol-in start none end) [bias 'none]])
|
|
(let ([med media])
|
|
(if (or (not med)
|
|
(send med get-printing)
|
|
(and (not allow-x-scroll?)
|
|
(not allow-y-scroll?)))
|
|
#f
|
|
(let-boxes ([x 0]
|
|
[y 0]
|
|
[iw 0]
|
|
[ih 0])
|
|
(get-view x y iw ih)
|
|
(if (or (zero? iw)
|
|
(zero? ih))
|
|
#f
|
|
(let ([find-dy (if scroll-bottom-based?
|
|
ih
|
|
0)])
|
|
(let-boxes ([cx 0]
|
|
[cy 0])
|
|
(get-scroll cx cy)
|
|
(let ([sy
|
|
(if allow-y-scroll?
|
|
(cond
|
|
[(or
|
|
;; doesn't fit and bias is set:
|
|
(and (eq? bias 'start) (fh . > . ih))
|
|
;; fits, need to shift down into view:
|
|
(and (fh . <= . ih) (localy . < . y) )
|
|
;; doesn't fit, no conflicting bias, can shift up to see more:
|
|
(and (fh . > . ih) (not (eq? bias 'end)) (localy . < . y)))
|
|
(- (send med find-scroll-line (+ find-dy localy))
|
|
scroll-offset)]
|
|
[(or
|
|
;; doesn't fit, bias is set:
|
|
(and (eq? bias 'end) (fh . > . ih))
|
|
;; fits, need to shift up into view:
|
|
(and (fh . <= . ih) ((+ y ih) . < . (+ localy fh))))
|
|
(let ([l (+ find-dy localy (- fh ih))])
|
|
;; find scroll pos for top of region to show:
|
|
(let ([sy (send med find-scroll-line l)])
|
|
;; unless l is exactly the top of a line, move down to the next whole line:
|
|
(let ([sy (if (= (send med scroll-line-location sy) l)
|
|
sy
|
|
(+ sy 1))])
|
|
(- sy scroll-offset))))]
|
|
[(or
|
|
;; doesn't fit, no conflicting bias, maybe shift down to see more:
|
|
(and (fh . > . ih)
|
|
(not (eq? bias 'start))
|
|
((+ localy fh) . > . (+ y ih))))
|
|
;; shift to one more than the first scroll position that shows last line
|
|
(let ([my (+ (send med find-scroll-line (+ find-dy localy (- fh ih)))
|
|
(- 1 scroll-offset))])
|
|
;; but only shift down the extra line if doing so doesn't skip the whole area
|
|
(cond
|
|
[((send med scroll-line-location my) . < . (+ find-dy localy fh))
|
|
my]
|
|
[(my . > . 0)
|
|
(- my 1)]
|
|
[else 0]))]
|
|
[else cy])
|
|
cy)]
|
|
[sx
|
|
(if allow-x-scroll?
|
|
(if (positive? hpixels-per-scroll)
|
|
(cond
|
|
[(or (and (eq? bias 'start) (fw . > . iw))
|
|
(and (fw . <= . iw) (localx . < . x))
|
|
(and (fw . > . iw) (not (eq? bias 'end)) (localx . < . x)))
|
|
(->long (/ localx hpixels-per-scroll))]
|
|
[(or (and (eq? bias 'end) (fw . > . iw))
|
|
(and (fw . <= . iw) ((+ x iw) . < . (+ localx fw)))
|
|
(and (fw . > . iw) (not (eq? bias 'start)) ((+ localx fw) . > . (+ x iw))))
|
|
(+ (->long (/ (+ localx (- fw iw)) hpixels-per-scroll)) 1)]
|
|
[else cx])
|
|
0)
|
|
cx)])
|
|
(if (or (not (= sy cy))
|
|
(not (= sx cx)))
|
|
(begin
|
|
(when hscroll
|
|
(send hscroll set-value sx))
|
|
(when vscroll
|
|
(send vscroll set-value sy))
|
|
(do-scroll sx sy refresh? cx cy)
|
|
#t)
|
|
#f)))))))))
|
|
|
|
(define/public (reset-visual reset-scroll?)
|
|
(if (given-h-scrolls-per-page . < . 0)
|
|
(begin
|
|
(set! given-h-scrolls-per-page -2)
|
|
#f)
|
|
(let loop ([retval #f] [iters 0])
|
|
(let-boxes ([sx 0]
|
|
[sy 0])
|
|
(get-scroll sx sy)
|
|
(let-boxes ([lw 0]
|
|
[lh 0])
|
|
(get-size lw lh)
|
|
(set! lastwidth lw)
|
|
(set! lastheight lh)
|
|
|
|
(let-values ([(x y vnum-scrolls hnum-scrolls vspp hspp)
|
|
(if (and media (or allow-x-scroll? allow-y-scroll?))
|
|
|
|
(let ([med media])
|
|
(let-values ([(x y)
|
|
(if reset-scroll?
|
|
(values 0 0)
|
|
(values sx sy))])
|
|
|
|
(let-boxes ([w 0.0]
|
|
[h 0.0])
|
|
(get-view #f #f w h)
|
|
(let-boxes ([total-width 0.0]
|
|
[total-height 0.0])
|
|
(send med get-extent total-width total-height)
|
|
|
|
(let-values ([(vnum-scrolls -scroll-offset)
|
|
(if (or (zero? h)
|
|
(and (not scroll-to-last?)
|
|
(h . >= . total-height)))
|
|
(values 0 0)
|
|
|
|
(if scroll-bottom-based?
|
|
(let ([vnum-scrolls (- (send med num-scroll-lines) 1)])
|
|
(if scroll-to-last?
|
|
(values vnum-scrolls 1)
|
|
(let ([start (- (send med find-scroll-line (+ h 1)) 1)])
|
|
(values (- vnum-scrolls start)
|
|
(+ 1 start)))))
|
|
(let ([top (max 0
|
|
(- (->long (- total-height
|
|
(if scroll-to-last?
|
|
0
|
|
h)))
|
|
1))])
|
|
(let ([vnum-scrolls (+ (send med find-scroll-line top) 1)]
|
|
[nsl (send med num-scroll-lines)])
|
|
(values (if (vnum-scrolls . >= . nsl)
|
|
(- nsl 1)
|
|
vnum-scrolls)
|
|
0)))))])
|
|
|
|
(set! scroll-offset -scroll-offset)
|
|
|
|
(let-values ([(vnum-scrolls vspp)
|
|
(if (positive? vnum-scrolls)
|
|
(let ([num-lines (- (send med num-scroll-lines) 1)])
|
|
(values vnum-scrolls
|
|
(max 1
|
|
(- (->long
|
|
(/ (* h num-lines)
|
|
total-height))
|
|
1))))
|
|
(values 0 1))])
|
|
|
|
(let-values ([(hnum-scrolls hspp)
|
|
(if (total-width . >= . w)
|
|
(let ([tw (->long (- total-width w))])
|
|
(set! hpixels-per-scroll
|
|
(let ([v (->long (/ w given-h-scrolls-per-page))])
|
|
(if (zero? v) 2 v)))
|
|
(let ([tw
|
|
(if (modulo tw hpixels-per-scroll)
|
|
(+ tw (- hpixels-per-scroll (modulo tw hpixels-per-scroll)))
|
|
tw)])
|
|
(values (->long (/ tw hpixels-per-scroll))
|
|
given-h-scrolls-per-page)))
|
|
(values 0 1))])
|
|
|
|
(values x y vnum-scrolls hnum-scrolls vspp hspp))))))))
|
|
|
|
(begin0
|
|
(values 0 0 0 0 1 1)
|
|
(when (not media)
|
|
(let ([dc (get-dc)])
|
|
(let ([bg (get-canvas-background)])
|
|
(when bg
|
|
(send dc set-background bg)
|
|
(send dc clear)))))))])
|
|
|
|
(if (not (and (= scroll-width hnum-scrolls)
|
|
(= scroll-height vnum-scrolls)
|
|
(= vspp vscrolls-per-page)
|
|
(= hspp hscrolls-per-page)
|
|
(= x sx)
|
|
(= y sy)))
|
|
(begin
|
|
(when hscroll
|
|
(send hscroll set-scroll hnum-scrolls hspp x))
|
|
(when vscroll
|
|
(send vscroll set-scroll vnum-scrolls vspp y))
|
|
(let ([savenoloop? noloop?]
|
|
[save-h-s-p-p given-h-scrolls-per-page])
|
|
(set! noloop? #t)
|
|
(set! given-h-scrolls-per-page -1)
|
|
|
|
(let ([xon? (and (not fake-x-scroll?) (not (zero? hnum-scrolls)))]
|
|
[yon? (and (not fake-y-scroll?) (not (zero? vnum-scrolls)))])
|
|
(let ([go-again?
|
|
(if (or (and auto-x? (not (eq? xon? xscroll-on?)))
|
|
(and auto-y? (not (eq? yon? yscroll-on?))))
|
|
(begin
|
|
(when auto-x?
|
|
(set! xscroll-on? xon?))
|
|
(when auto-y?
|
|
(set! yscroll-on? yon?))
|
|
(show-scrollbars xscroll-on? yscroll-on?)
|
|
(on-scroll-on-change)
|
|
#t)
|
|
#f)])
|
|
|
|
(unless fake-x-scroll?
|
|
(let ([x (min x hnum-scrolls)])
|
|
(when (hspp . < . hscrolls-per-page)
|
|
(set-scroll-page 'horizontal (min hspp 10000000)))
|
|
(when (x . < . sx)
|
|
(set-scroll-pos 'horizontal x))
|
|
(when (not (= scroll-width hnum-scrolls))
|
|
(set-scroll-range 'horizontal (min hnum-scrolls 10000000)))
|
|
(when (x . > . sx)
|
|
(set-scroll-pos 'horizontal (min x 10000000)))
|
|
(when (hspp . > . hscrolls-per-page)
|
|
(set-scroll-page 'horizontal (min hspp 10000000)))))
|
|
|
|
(unless fake-y-scroll?
|
|
(let ([y (min y vnum-scrolls)])
|
|
(when (vspp . < . vscrolls-per-page)
|
|
(set-scroll-page 'vertical (min vspp 10000000)))
|
|
(when (y . < . sy)
|
|
(set-scroll-pos 'vertical (min y 10000000)))
|
|
(when (not (= scroll-height vnum-scrolls))
|
|
(set-scroll-range 'vertical (min vnum-scrolls 10000000)))
|
|
(when (y . > . sy)
|
|
(set-scroll-pos 'vertical (min y 10000000)))
|
|
(when (vspp . > . vscrolls-per-page)
|
|
(set-scroll-page 'vertical (min vspp 10000000)))))
|
|
|
|
(let ([go-again? (or go-again?
|
|
(given-h-scrolls-per-page . < . -1))])
|
|
(set! given-h-scrolls-per-page save-h-s-p-p)
|
|
(set! noloop? savenoloop?)
|
|
(set! hscrolls-per-page hspp)
|
|
(set! vscrolls-per-page vspp)
|
|
(set! scroll-width hnum-scrolls)
|
|
(set! scroll-height vnum-scrolls)
|
|
|
|
(when (and go-again? (iters . > . 2))
|
|
;; we're not reaching a fixpoint, so
|
|
;; it seems that a horizontal scroll
|
|
;; is needed iff there's a vertical
|
|
;; scrollbar; force a fixpoint
|
|
(cond
|
|
[(and auto-x? auto-y?)
|
|
(set! xscroll-on? #f)
|
|
(set! yscroll-on? #f)]
|
|
;; I don't think these cases are possible,
|
|
;; but in case I have it wrong, conservatively
|
|
;; force scrollbars on.
|
|
[auto-x? (set! xscroll-on? #t)]
|
|
[auto-y? (set! yscroll-on? #t)])
|
|
(show-scrollbars xscroll-on? yscroll-on?))
|
|
|
|
(if go-again?
|
|
(loop #t (add1 iters))
|
|
#t))))))
|
|
|
|
retval)))))))
|
|
|
|
(define/private (do-scroll x y refresh? old-x old-y)
|
|
(let ([savenoloop? noloop?])
|
|
(set! noloop? #t)
|
|
|
|
(maybe-reset-size)
|
|
|
|
(define change?
|
|
(or
|
|
;; Set x
|
|
(and (x . > . -1)
|
|
(positive? scroll-width)
|
|
(let ([x (min (->long (min x scroll-width)) 10000000)])
|
|
(and (not (= x old-x))
|
|
(begin
|
|
(when (not fake-x-scroll?)
|
|
(set-scroll-pos 'horizontal x))
|
|
#t))))
|
|
;; Set y
|
|
(and (y . > . -1)
|
|
(positive? scroll-height)
|
|
(let ([y (min (->long (min y scroll-height)) 10000000)])
|
|
(and (not (= y old-y))
|
|
(begin
|
|
(when (not fake-y-scroll?)
|
|
(set-scroll-pos 'vertical y))
|
|
#t))))))
|
|
|
|
(set! noloop? savenoloop?)
|
|
|
|
(when (and change? refresh?)
|
|
(if (and #f ;; special scrolling disabled: not faster with Cocoa, broken for Windows
|
|
(not need-refresh?)
|
|
(not lazy-refresh?)
|
|
(get-canvas-background)
|
|
(= x old-x)) ; could handle horizontal scrolling in the future
|
|
(let-boxes ([fx 0]
|
|
[old-fy 0]
|
|
[new-fy 0])
|
|
(begin
|
|
(convert-scroll-to-location x y fx new-fy)
|
|
(convert-scroll-to-location old-x old-y #f old-fy))
|
|
(let-boxes ([vx 0][vy 0][vw 0][vh 0])
|
|
(get-view vx vy vw vh) ; editor coords
|
|
(cond
|
|
[(and (new-fy . < . old-fy)
|
|
(old-fy . < . (+ new-fy vh)))
|
|
(let ([dc (get-dc)])
|
|
(send dc copy
|
|
xmargin ymargin
|
|
vw (- (+ new-fy vh) old-fy)
|
|
xmargin (+ ymargin (- old-fy new-fy)))
|
|
(redraw vx vy
|
|
vw (- old-fy new-fy)
|
|
#t))]
|
|
[(and (old-fy . < . new-fy)
|
|
(new-fy . < . (+ old-fy vh)))
|
|
(let ([dc (get-dc)])
|
|
(send dc copy
|
|
xmargin (+ ymargin (- new-fy old-fy))
|
|
vw (- (+ old-fy vh) new-fy)
|
|
xmargin ymargin)
|
|
(let ([d (- (+ old-fy vh) new-fy)])
|
|
(redraw vx (+ vy d)
|
|
vw (- vh d)
|
|
#t)))]
|
|
[else (repaint)])))
|
|
(repaint)))))
|
|
|
|
(define/override (set-scrollbars x y x2 y2 x3 y3 x4 y4 ?) (void))
|
|
|
|
(define/public (get-scroll x y)
|
|
;; get fake scroll values if available
|
|
(set-box! x (if hscroll
|
|
(send hscroll get-value)
|
|
(get-scroll-pos 'horizontal)))
|
|
(set-box! y (if vscroll
|
|
(send vscroll get-value)
|
|
(get-scroll-pos 'vertical))))
|
|
|
|
(define/public (editor-canvas-on-scroll)
|
|
(unless noloop?
|
|
(repaint)))
|
|
|
|
(define/public (on-scroll-on-change)
|
|
(void))
|
|
|
|
(define/public (get-editor) media)
|
|
|
|
(define/public (set-editor m [update? #t])
|
|
(unless (eq? media m)
|
|
(when media
|
|
(when (object/bool=? admin (send media get-admin))
|
|
(send media set-admin
|
|
(or (send admin get-nextadmin)
|
|
(send admin get-prevadmin))))
|
|
|
|
(let ([a (send admin get-nextadmin)])
|
|
(when a
|
|
(send a set-prevadmin (send admin get-prevadmin))
|
|
(send a adjust-std-flag)))
|
|
(let ([a (send admin get-prevadmin)])
|
|
(when a
|
|
(send a set-nextadmin (send admin get-nextadmin))
|
|
(send a adjust-std-flag)))
|
|
(send admin set-nextadmin #f)
|
|
(send admin set-prevadmin #f)
|
|
(when custom-cursor
|
|
(no-custom-cursor)
|
|
(set! custom-cursor #f)))
|
|
(set! media m)
|
|
(when media
|
|
(let ([oldadmin (send media get-admin)])
|
|
(if (and oldadmin
|
|
(not (send oldadmin get-s-standard)))
|
|
(set! media #f)
|
|
(if oldadmin
|
|
(begin
|
|
(unless (in-chain? admin oldadmin)
|
|
(send admin set-nextadmin oldadmin)
|
|
(send admin set-prevadmin (send oldadmin get-prevadmin))
|
|
(send oldadmin set-prevadmin admin)
|
|
(send oldadmin adjust-std-flag)
|
|
(let ([a (send admin get-prevadmin)])
|
|
(when a
|
|
(send a set-nextadmin admin)
|
|
(send a adjust-std-flag))))
|
|
;; get the right cursor:
|
|
(send admin update-cursor))
|
|
(begin
|
|
(send admin set-nextadmin #f)
|
|
(send admin set-prevadmin #f)
|
|
(send media set-admin admin)
|
|
(send media own-caret focuson?))))))
|
|
(send admin adjust-std-flag)
|
|
(reset-visual #t)
|
|
(when update?
|
|
(repaint))))
|
|
|
|
(define/private (in-chain? admin oldadmin)
|
|
(or (let loop ([oldadmin oldadmin])
|
|
(and oldadmin
|
|
(or (object/bool=? admin oldadmin)
|
|
(loop (send oldadmin get-prevadmin)))))
|
|
(let loop ([oldadmin oldadmin])
|
|
(and oldadmin
|
|
(or (object/bool=? admin oldadmin)
|
|
(loop (send oldadmin get-nextadmin)))))))
|
|
|
|
(define/public (allow-scroll-to-last to-last?)
|
|
(set! scroll-to-last? to-last?)
|
|
(reset-visual #f)
|
|
(repaint))
|
|
|
|
(define/public (scroll-with-bottom-base bottom?)
|
|
(set! scroll-bottom-based? bottom?)
|
|
(reset-visual #f)
|
|
(repaint)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(defclass canvas-editor-admin% editor-admin%
|
|
(init-field canvas)
|
|
|
|
(super-new)
|
|
|
|
(inherit set-s-standard)
|
|
|
|
(define reset? #f)
|
|
(properties [[any? nextadmin] #f]
|
|
[[any? prevadmin] #f])
|
|
|
|
(define update-cursor-timer #f)
|
|
|
|
(define update-block? #f)
|
|
(define resized-block? #f)
|
|
|
|
;; FIXME: needed?
|
|
(define/private (~)
|
|
(when update-cursor-timer
|
|
(send update-cursor-timer cancel)
|
|
(set! update-cursor-timer #f))
|
|
(set! canvas #f))
|
|
|
|
(define/public (do-get-canvas) canvas)
|
|
|
|
(define canvasless-offscreen #f)
|
|
|
|
(define/override (get-dc [fx #f] [fy #f])
|
|
(cond
|
|
[(not canvas)
|
|
(unless canvasless-offscreen
|
|
(set! canvasless-offscreen (new bitmap-dc%)))
|
|
(when fx (set-box! fx 0))
|
|
(when fy (set-box! fy 0))
|
|
canvasless-offscreen]
|
|
[(let ([m (send canvas get-editor)])
|
|
(and m (send m get-printing)))
|
|
=> (lambda (p)
|
|
(when fx (set-box! fx 0))
|
|
(when fy (set-box! fy 0))
|
|
p)]
|
|
[else
|
|
(send canvas get-dc-and-offset fx fy)]))
|
|
|
|
(define/override (get-view fx fy fh fw [full? #f])
|
|
(cond
|
|
[(not canvas)
|
|
(when fx (set-box! fx 0))
|
|
(when fy (set-box! fy 0))
|
|
(when fh (set-box! fh 1))
|
|
(when fw (set-box! fw 1))]
|
|
[(let ([m (send canvas get-editor)])
|
|
(and m (send m get-printing)))
|
|
(when fx (set-box! fx 0))
|
|
(when fy (set-box! fy 0))
|
|
(when fh (set-box! fh 10000))
|
|
(when fw (set-box! fw 10000))]
|
|
[else
|
|
(send canvas get-view fx fy fh fw full?)]))
|
|
|
|
(define/override (get-max-view fx fy fw fh [full? #f])
|
|
(if (or (and (not nextadmin)
|
|
(not prevadmin))
|
|
(not canvas)
|
|
(and (let ([m (send canvas get-editor)])
|
|
(and m (send m get-printing)))))
|
|
(get-view fx fy fw fh full?)
|
|
(let ([a (let loop ([a this])
|
|
(let ([a2 (send a get-prevadmin)])
|
|
(if a2
|
|
(loop a2)
|
|
a)))])
|
|
(let-boxes ([cx 0] [cy 0] [cw 0] [ch 0])
|
|
(send a get-view cx cy cw ch)
|
|
(let loop ([a (send a get-nextadmin)]
|
|
[cx cx][cy cy][cr (+ cx cw)][cb (+ cy ch)])
|
|
(if (not a)
|
|
(let ([cw (- cr cx)]
|
|
[ch (- cb cy)])
|
|
(when fx (set-box! fx cx))
|
|
(when fy (set-box! fy cy))
|
|
(when fw (set-box! fw cw))
|
|
(when fh (set-box! fh ch)))
|
|
(let-boxes ([x 0] [y 0] [w 0] [h 0])
|
|
(send a get-view x y w h)
|
|
(loop (send a get-nextadmin)
|
|
(min x cx)
|
|
(min y cy)
|
|
(max (+ x w) cr)
|
|
(max (+ y h) cb)))))))))
|
|
|
|
(def/override (scroll-to [real? localx] [real? localy] [real? w] [real? h] [any? [refresh? #t]]
|
|
[(symbol-in start none end) [bias 'none]])
|
|
(let ([v (do-scroll-to localx localy w h refresh? bias #t #t #f)])
|
|
(and v (car v))))
|
|
|
|
(define/public (do-scroll-to localx localy w h refresh? bias prev? next? only-focus?)
|
|
(and canvas
|
|
(or (and (not (send canvas is-focus-on?))
|
|
(or
|
|
(and prev?
|
|
prevadmin
|
|
(send prevadmin do-scroll-to localx localy w h refresh? bias #t #f #t))
|
|
(and next?
|
|
nextadmin
|
|
(send nextadmin do-scroll-to localx localy w h refresh? bias #f #t #t))))
|
|
(and (or (not only-focus?)
|
|
(send canvas is-focus-on?))
|
|
(list (send canvas scroll-to localx localy w h refresh? bias))))))
|
|
|
|
(def/override (grab-caret [(symbol-in immediate display global) [dist 'global]])
|
|
(when canvas
|
|
(when (eq? dist 'global)
|
|
(send canvas set-focus))))
|
|
|
|
(define/public all-in-chain
|
|
(case-lambda
|
|
[(proc) (all-in-chain proc #t #t)]
|
|
[(proc backward? forward?)
|
|
(proc this)
|
|
(when (and forward? nextadmin)
|
|
(send nextadmin all-in-chain proc #f #t))
|
|
(when (and backward? prevadmin)
|
|
(send prevadmin all-in-chain proc #t #f))]))
|
|
|
|
(def/override (needs-update [real? localx] [real? localy]
|
|
[nonnegative-real? w] [nonnegative-real? h])
|
|
(all-in-chain (lambda (a) (send a do-needs-update localx localy w h))))
|
|
|
|
(define/public (do-needs-update localx localy w h)
|
|
(when canvas
|
|
(let ([is-shown? (send canvas is-shown-to-root?)])
|
|
|
|
(cond
|
|
[reset?
|
|
(when is-shown? (send canvas repaint))
|
|
(set! reset? #f)]
|
|
[is-shown?
|
|
(if (not (send canvas get-canvas-background))
|
|
(send canvas repaint)
|
|
(send canvas redraw localx localy w h #f))]))))
|
|
|
|
(define/override (resized update?)
|
|
(all-in-chain (lambda (a) (send a do-resized update?))))
|
|
|
|
(define/public (do-resized update?)
|
|
(when canvas
|
|
(when (send canvas reset-visual #f)
|
|
(set! reset? #t))
|
|
|
|
(when update?
|
|
(send canvas repaint)
|
|
(set! reset? #f))))
|
|
|
|
(define/override (update-cursor)
|
|
(all-in-chain (lambda (a) (send a do-update-cursor))))
|
|
|
|
(define/public (do-update-cursor)
|
|
(when (not update-cursor-timer)
|
|
(set! update-cursor-timer (new update-cursor-timer% [admin this]))))
|
|
|
|
(def/override (popup-menu [popup-menu% m] [real? x] [real? y])
|
|
(and canvas
|
|
(let ([e (send canvas get-editor)])
|
|
(and e
|
|
(let ([m (send canvas popup-for-editor e m)])
|
|
(let-boxes ([dx 0.0]
|
|
[dy 0.0])
|
|
(send canvas get-dc-and-offset dx dy)
|
|
(send canvas popup-menu m (->long (- x dx)) (->long (- y dy)))))))))
|
|
|
|
(define/public (adjust-std-flag)
|
|
;; 1 indicates that this is the sole, main admin.
|
|
;; this info is used for quick (xor) caret refreshing
|
|
;; by an editor buffer
|
|
(set-s-standard (if (or nextadmin
|
|
prevadmin
|
|
(and canvas (send canvas get-focusforcedon?)))
|
|
-1
|
|
1)))
|
|
|
|
(def/override (modified [bool? modified?]) (void)))
|