150 lines
5.2 KiB
Racket
150 lines
5.2 KiB
Racket
#lang scheme/base
|
|
(require scheme/class
|
|
"../syntax.ss"
|
|
"snip.ss"
|
|
(only-in "cycle.ss"
|
|
set-snip-admin%!
|
|
popup-menu%)
|
|
"wx.ss")
|
|
|
|
(provide snip-admin%
|
|
standard-snip-admin%)
|
|
|
|
(defclass snip-admin% object%
|
|
(super-new)
|
|
|
|
(def/public (get-editor) #f)
|
|
(def/public (get-dc) #f)
|
|
(def/public (get-view-size [maybe-box? w] [maybe-box? h])
|
|
#f)
|
|
|
|
(def/public (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h]
|
|
[(make-or-false snip%) [snip #f]])
|
|
#f)
|
|
|
|
(def/public (scroll-to [snip% s]
|
|
[real? x] [real? y]
|
|
[nonnegative-real? w] [nonnegative-real? h]
|
|
[any? refresh?]
|
|
[(symbol-in start end none) [bias 'none]])
|
|
#f)
|
|
|
|
(def/public (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist])
|
|
(void))
|
|
|
|
(def/public (resized [snip% s] [any? redraw?]) (void))
|
|
|
|
(def/public (recounted [snip% s] [any? redraw?]) (void))
|
|
|
|
(def/public (needs-update [snip% s] [real? x] [real? y]
|
|
[nonnegative-real? w] [nonnegative-real? h])
|
|
(void))
|
|
|
|
(def/public (release-snip [snip% s]) #f)
|
|
|
|
(def/public (update-cursor) (void))
|
|
|
|
(def/public (popup-menu [popup-menu% p][snip% snip][real? x][real? y])
|
|
#f)
|
|
|
|
(def/public (modified [snip% s] [any? modified?])
|
|
(void)))
|
|
|
|
(set-snip-admin%! snip-admin%)
|
|
|
|
(defclass standard-snip-admin% snip-admin%
|
|
(init-field editor)
|
|
|
|
(super-new)
|
|
|
|
(def/override (get-editor) editor)
|
|
(def/override (get-dc) (send editor get-dc))
|
|
(def/override (get-view-size [maybe-box? w] [maybe-box? h])
|
|
(get-view #f #f w h #f))
|
|
|
|
(def/override (get-view [maybe-box? x] [maybe-box? y] [maybe-box? w] [maybe-box? h]
|
|
[(make-or-false snip%) snip])
|
|
(let ([admin (send editor get-admin)]
|
|
[zeros (lambda ()
|
|
(when x (set-box! x 0.0))
|
|
(when y (set-box! y 0.0))
|
|
(when w (set-box! w 0.0))
|
|
(when h (set-box! h 0.0)))])
|
|
(if snip
|
|
(if admin
|
|
(let-boxes ([mx 0.0] [my 0.0]
|
|
[mw 0.0] [mh 0.0])
|
|
(send admin get-view mx my mw mh #f)
|
|
(let ([mb (+ my mh)]
|
|
[mr (+ mx mw)])
|
|
(let-boxes ([ok? #f]
|
|
[sl 0.0]
|
|
[st 0.0])
|
|
(set-box! ok? (if (send editor locked-for-read?)
|
|
#f
|
|
(send editor get-snip-location snip sl st #f)))
|
|
(if ok?
|
|
(let-boxes ([sr 0.0][sb 0.0])
|
|
(send editor get-snip-location snip sr sb #t)
|
|
(let ([l (max mx sl)]
|
|
[t (max my st)]
|
|
[r (min mr sr)]
|
|
[b (min mb sb)])
|
|
(when x (set-box! x (- l sl)))
|
|
(when y (set-box! y (- t st)))
|
|
(when w (set-box! w (max 0 (- r l))))
|
|
(when h (set-box! h (max 0 (- b t))))))
|
|
(zeros)))))
|
|
(zeros))
|
|
(if admin
|
|
(send admin get-view x y w h #t)
|
|
(zeros)))))
|
|
|
|
(def/override (scroll-to [snip% s]
|
|
[real? localx] [real? localy]
|
|
[nonnegative-real? w] [nonnegative-real? h]
|
|
[any? [refresh? #t]]
|
|
[(symbol-in start end none) [bias 'none]])
|
|
(and (eq? (send s get-admin) this)
|
|
(send editor scroll-to s localx localy w h refresh? bias)))
|
|
|
|
(def/override (set-caret-owner [snip% s] [(symbol-in imeditorte display global) dist])
|
|
(when (eq? (send s get-admin) this)
|
|
(send editor set-caret-owner s dist)))
|
|
|
|
(def/override (resized [snip% s] [any? redraw?])
|
|
(when (eq? (send s get-admin) this)
|
|
(send editor resized s redraw?)))
|
|
|
|
(def/override (recounted [snip% s] [any? redraw?])
|
|
(when (eq? (send s get-admin) this)
|
|
(send editor recounted s redraw?)))
|
|
|
|
(def/override (needs-update [snip% s] [real? localx] [real? localy]
|
|
[nonnegative-real? w] [nonnegative-real? h])
|
|
(when (eq? (send s get-admin) this)
|
|
(send editor needs-update s localx localy w h)))
|
|
|
|
(def/override (release-snip [snip% s])
|
|
(and (eq? (send s get-admin) this)
|
|
(send editor release-snip s)))
|
|
|
|
(def/override (update-cursor)
|
|
(let ([admin (send editor get-admin)])
|
|
(when admin
|
|
(send admin update-cursor))))
|
|
|
|
(def/override (popup-menu [popup-menu% m][snip% snip][real? x][real? y])
|
|
(let ([admin (send editor get-admin)])
|
|
(and admin
|
|
(let-boxes ([sl 0.0]
|
|
[st 0.0]
|
|
[ok? #f])
|
|
(set-box! ok? (send editor get-snip-location snip sl st #f))
|
|
(and ok?
|
|
(send admin popup-menu m (+ x sl) (+ y st)))))))
|
|
|
|
(def/override (modified [snip% s] [any? modified?])
|
|
(when (eq? (send s get-admin) this)
|
|
(send editor on-snip-modified s modified?))))
|