1284 lines
48 KiB
Racket
1284 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)
|
|
(begin-refresh-sequence)
|
|
(let-boxes ([w 0]
|
|
[h 0])
|
|
(get-size w h)
|
|
(unless (and (= w lastwidth)
|
|
(= h lastheight))
|
|
(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 ([adc (get-dc)])
|
|
(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 localy 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 xmargin ymargin
|
|
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 xmargin (+ ymargin 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)))
|