136 lines
5.2 KiB
Racket
136 lines
5.2 KiB
Racket
#lang racket/gui
|
|
(require framework
|
|
slideshow/pict
|
|
"display.rkt")
|
|
(provide pict-canvas%)
|
|
|
|
|
|
(define pict-canvas%
|
|
(class canvas%
|
|
(init pict-builder [hover-handler #f]
|
|
[click-handler #f]
|
|
[overlay-builder #f]
|
|
[redraw-on-resize #f])
|
|
(inherit get-dc get-client-size refresh get-view-start)
|
|
(define bp pict-builder) ;Builds the main pict for the canvas
|
|
(define mh hover-handler) ;Mouse hover handler
|
|
(define ob overlay-builder) ;Hover overlay pict builder
|
|
(define ch click-handler) ;Mouse click handler
|
|
(define redraw-on-size redraw-on-resize) ;Whether we should rebuild the pict for on-size events
|
|
|
|
(define redraw-overlay #f) ;Whether we should redraw the overlay pict in the canvas
|
|
(define redo-bitmap-on-paint #t) ;Redraw the base bitmap on paint? #f for mouse events
|
|
(define scale-factor 1)
|
|
|
|
;;set-redraw-overlay! : bool -> void
|
|
(define/public (set-redraw-overlay! b)
|
|
(set! redraw-overlay b))
|
|
|
|
(define/public (set-scale-factor! s)
|
|
(set! scale-factor s))
|
|
|
|
(define needs-redraw #f)
|
|
(define delaying-redraw #f)
|
|
(define cached-bitmap #f)
|
|
(define cached-base-pict #f)
|
|
(define repainting? #f)
|
|
|
|
(define/private (get-viewable-region)
|
|
(define-values (x y) (get-view-start))
|
|
(define-values (w h) (get-client-size))
|
|
(scale-viewable-region (viewable-region x y w h) (/ 1 scale-factor)))
|
|
|
|
(define/public (redraw-everything)
|
|
(redraw-the-bitmap/maybe-delayed! (get-viewable-region)))
|
|
|
|
;Rebuild both the bottom (base) and overlay (top)
|
|
;pict layers for the canvas
|
|
;;rebuild-the-pict : viewable-region -> void
|
|
(define/private (rebuild-the-pict vregion #:only-the-overlay? [only-the-overlay? #f])
|
|
(define p (cond
|
|
[(or (not cached-base-pict) (not only-the-overlay?))
|
|
(define base (scale (bp vregion) scale-factor))
|
|
(set! cached-base-pict base)
|
|
(if ob
|
|
(pin-over base
|
|
0
|
|
0
|
|
(ob vregion scale-factor))
|
|
base)]
|
|
[else (if ob
|
|
(pin-over cached-base-pict
|
|
0
|
|
0
|
|
(ob vregion scale-factor))
|
|
cached-base-pict)]))
|
|
(pict->bitmap p))
|
|
|
|
;Rebuilds the pict and stashes in a bitmap
|
|
;to be drawn to the canvas later
|
|
;;redraw-the-bitmap : viewable-region -> void
|
|
(define/private (redraw-the-bitmap! vregion #:only-the-overlay? [only-the-overlay? #f])
|
|
(set! cached-bitmap (rebuild-the-pict vregion #:only-the-overlay? only-the-overlay?))
|
|
(set! needs-redraw #f))
|
|
|
|
;;redraw-the-bitmap/maybe-delayed! : viewable-region -> void
|
|
(define/private (redraw-the-bitmap/maybe-delayed! vregion
|
|
#:only-the-overlay? [only-the-overlay? #f])
|
|
(cond
|
|
[needs-redraw (redraw-the-bitmap! vregion #:only-the-overlay? only-the-overlay?)]
|
|
[(not delaying-redraw)
|
|
(new timer% [notify-callback (λ ()
|
|
(set! delaying-redraw #f)
|
|
(set! needs-redraw #t)
|
|
(redraw-the-bitmap/maybe-delayed! (get-viewable-region) #:only-the-overlay? only-the-overlay?)
|
|
(set! repainting? #t)
|
|
(refresh))]
|
|
[interval 100]
|
|
[just-once? #t])
|
|
(set! delaying-redraw #t)]))
|
|
|
|
;If we haven't already introduced a 100ms delay,
|
|
;add one. If the delay's expired, rebuild the pict
|
|
;;on-size : uint uint -> void
|
|
(define/override (on-size width height)
|
|
(when redraw-on-size
|
|
(redraw-the-bitmap/maybe-delayed! (get-viewable-region))))
|
|
|
|
(define/override (on-paint)
|
|
(define vregion (get-viewable-region))
|
|
(unless repainting?
|
|
(redraw-the-bitmap/maybe-delayed! vregion))
|
|
(set! repainting? #f)
|
|
(define dc (get-dc))
|
|
(when cached-bitmap
|
|
(send dc
|
|
draw-bitmap
|
|
cached-bitmap
|
|
(viewable-region-x vregion)
|
|
(viewable-region-y vregion))))
|
|
|
|
(define/override (on-event event)
|
|
(define vregion (get-viewable-region))
|
|
(define x (+ (viewable-region-x vregion) (/ (send event get-x) scale-factor)))
|
|
(define y (+ (viewable-region-y vregion) (/ (send event get-y) scale-factor)))
|
|
(case (send event get-event-type)
|
|
[(motion)
|
|
(when mh
|
|
(when (mh x y vregion) ;Mouse handler returns non-false if a state change requiring redraw occurred
|
|
(redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t)))]
|
|
[(left-up)
|
|
(when ch (ch x y vregion)) ;Ditto for click handler
|
|
(redraw-the-bitmap/maybe-delayed! vregion #:only-the-overlay? #t)]))
|
|
|
|
(super-new)
|
|
(send (get-dc) set-smoothing 'aligned)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|