661 lines
25 KiB
Racket
661 lines
25 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
racket/draw
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/canvas-mixin.rkt"
|
|
"../common/backing-dc.rkt"
|
|
"../common/event.rkt"
|
|
"../common/freeze.rkt"
|
|
"../common/queue.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"wndclass.rkt"
|
|
"window.rkt"
|
|
"dc.rkt"
|
|
"item.rkt"
|
|
"hbitmap.rkt"
|
|
"gcwin.rkt"
|
|
"theme.rkt"
|
|
"panel.rkt")
|
|
|
|
(provide
|
|
(protect-out canvas%
|
|
canvas-panel%))
|
|
|
|
(define WS_EX_STATICEDGE #x00020000)
|
|
(define WS_EX_CLIENTEDGE #x00000200)
|
|
|
|
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
|
|
(define-user32 EndPaint (_wfun _HWND _pointer -> _BOOL))
|
|
(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL)
|
|
-> (unless r (failed 'ShowScrollbar))))
|
|
|
|
(define-gdi32 CreateSolidBrush (_wfun _COLORREF -> _HBRUSH))
|
|
(define-user32 FillRect (_wfun _HDC _RECT-pointer _HBRUSH -> (r : _int)
|
|
-> (when (zero? r) (failed 'FillRect))))
|
|
|
|
(define _HRGN _pointer)
|
|
(define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC))
|
|
(define DCX_WINDOW #x00000001)
|
|
(define DCX_CACHE #x00000002)
|
|
(define DCX_INTERSECTRGN #x00000080)
|
|
|
|
(define EP_EDITTEXT 1)
|
|
(define ETS_NORMAL 1)
|
|
(define ETS_DISABLE 4)
|
|
|
|
(define HTHSCROLL 6)
|
|
(define HTVSCROLL 7)
|
|
|
|
(define CB_SHOWDROPDOWN #x014F)
|
|
|
|
(define-cstruct _SCROLLINFO
|
|
([cbSize _UINT]
|
|
[fMask _UINT]
|
|
[nMin _int]
|
|
[nMax _int]
|
|
[nPage _UINT]
|
|
[nPos _int]
|
|
[nTrackPos _int]))
|
|
|
|
(define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int))
|
|
(define-user32 GetScrollPos (_wfun _HWND _int -> _int))
|
|
(define-user32 SetScrollPos (_wfun _HWND _int _int _BOOL -> _int))
|
|
(define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer
|
|
= (make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
|
|
(bitwise-ior SIF_RANGE SIF_POS
|
|
SIF_PAGE SIF_TRACKPOS)
|
|
0 0 0 0 0))
|
|
-> (r : _BOOL)
|
|
-> (if r i (failed 'GetScrollInfo))))
|
|
|
|
(define COMBO-WIDTH 18)
|
|
|
|
(define canvas%
|
|
(canvas-mixin
|
|
(class (canvas-autoscroll-mixin (item-mixin window%))
|
|
(init parent
|
|
x y w h
|
|
style
|
|
[ignored-name #f]
|
|
[gl-conf #f])
|
|
|
|
(inherit get-hwnd
|
|
get-client-size
|
|
get-eventspace
|
|
set-control-font
|
|
is-auto-scroll? is-disabled-scroll?
|
|
get-virtual-width get-virtual-height
|
|
reset-auto-scroll
|
|
refresh-for-autoscroll
|
|
try-mouse)
|
|
|
|
(define hscroll? (or (memq 'hscroll style)
|
|
(memq 'auto-hscroll style)))
|
|
(define vscroll? (or (memq 'vscroll style)
|
|
(memq 'auto-vscroll style)))
|
|
(define for-gl? (memq 'gl style))
|
|
|
|
(define panel-hwnd
|
|
(and (memq 'combo style)
|
|
(CreateWindowExW 0
|
|
"PLTTabPanel"
|
|
#f
|
|
(bitwise-ior WS_CHILD)
|
|
0 0 (->screen w) (->screen h)
|
|
(send parent get-content-hwnd)
|
|
#f
|
|
hInstance
|
|
#f)))
|
|
|
|
(define canvas-hwnd
|
|
(CreateWindowExW (cond
|
|
[(memq 'border style) WS_EX_STATICEDGE]
|
|
[(memq 'control-border style) WS_EX_CLIENTEDGE]
|
|
[else 0])
|
|
"PLTCanvas"
|
|
#f
|
|
(bitwise-ior WS_CHILD
|
|
(if panel-hwnd WS_VISIBLE 0)
|
|
(if hscroll? WS_HSCROLL 0)
|
|
(if vscroll? WS_VSCROLL 0))
|
|
0 0 (->screen w) (->screen h)
|
|
(or panel-hwnd (send parent get-content-hwnd))
|
|
#f
|
|
hInstance
|
|
#f))
|
|
(define combo-hwnd
|
|
(and panel-hwnd
|
|
(CreateWindowExW/control 0
|
|
"PLTCOMBOBOX"
|
|
""
|
|
(bitwise-ior WS_CHILD WS_VISIBLE
|
|
CBS_DROPDOWNLIST
|
|
WS_HSCROLL WS_VSCROLL
|
|
WS_BORDER WS_CLIPSIBLINGS)
|
|
0 0 (->screen w) (->screen h)
|
|
panel-hwnd
|
|
#f
|
|
hInstance
|
|
#f)))
|
|
|
|
(define content-hwnd
|
|
(if (is-panel?)
|
|
(CreateWindowExW 0
|
|
"PLTTabPanel"
|
|
#f
|
|
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
|
|
0 0 (->screen w) (->screen h)
|
|
canvas-hwnd
|
|
#f
|
|
hInstance
|
|
#f)
|
|
canvas-hwnd))
|
|
|
|
(define hwnd (or panel-hwnd canvas-hwnd))
|
|
(define dc #f)
|
|
|
|
(define next-scroll-is-change? #f)
|
|
|
|
(super-new [parent parent]
|
|
[hwnd hwnd]
|
|
[extra-hwnds (if panel-hwnd
|
|
(list canvas-hwnd combo-hwnd)
|
|
(if (eq? content-hwnd canvas-hwnd)
|
|
null
|
|
(list content-hwnd)))]
|
|
[style style])
|
|
|
|
(when combo-hwnd
|
|
(set-control-font #f combo-hwnd))
|
|
|
|
(define control-border-theme
|
|
(and (memq 'control-border style)
|
|
(OpenThemeData canvas-hwnd "Edit")))
|
|
|
|
(define/override (get-content-hwnd)
|
|
content-hwnd)
|
|
|
|
(define/override (wndproc w msg wParam lParam default)
|
|
(cond
|
|
[(= msg WM_PAINT)
|
|
(let* ([ps (malloc 128)]
|
|
[hdc (BeginPaint w ps)])
|
|
(when hdc
|
|
(if for-gl?
|
|
(queue-paint)
|
|
(if (positive? paint-suspended)
|
|
(set! suspended-refresh? #t)
|
|
(let ([erase
|
|
(lambda ()
|
|
(let* ([hbrush (if no-autoclear?
|
|
#f
|
|
(if transparent?
|
|
background-hbrush
|
|
(CreateSolidBrush bg-colorref)))])
|
|
(when hbrush
|
|
(let ([r (GetClientRect canvas-hwnd)])
|
|
(FillRect hdc r hbrush))
|
|
(unless transparent?
|
|
(DeleteObject hbrush)))))])
|
|
(when transparent? (erase))
|
|
(unless (do-canvas-backing-flush hdc)
|
|
(unless transparent? (erase))
|
|
(queue-paint)))))
|
|
(EndPaint w ps)))
|
|
0]
|
|
[(= msg WM_NCPAINT)
|
|
(if control-border-theme
|
|
(let* ([r (GetWindowRect canvas-hwnd)]
|
|
[res (default w msg wParam lParam)]
|
|
[hrgn (if (= wParam 1) ;; check is needed for Win7
|
|
#f
|
|
(cast wParam _intptr _HRGN))]
|
|
[hdc (GetDCEx canvas-hwnd hrgn
|
|
(bitwise-ior DCX_CACHE DCX_WINDOW
|
|
(if hrgn
|
|
DCX_INTERSECTRGN
|
|
0)))]
|
|
[wr (make-RECT 0 0
|
|
(- (RECT-right r) (RECT-left r))
|
|
(- (RECT-bottom r) (RECT-top r)))])
|
|
(DrawThemeBackground control-border-theme
|
|
hdc
|
|
EP_EDITTEXT
|
|
ETS_NORMAL ;; or ETS_DISABLED?
|
|
wr
|
|
#f)
|
|
(ReleaseDC canvas-hwnd hdc)
|
|
1)
|
|
(default w msg wParam lParam))]
|
|
[(= msg WM_HSCROLL)
|
|
(when hscroll?
|
|
(on-scroll-change SB_HORZ wParam))
|
|
0]
|
|
[(= msg WM_VSCROLL)
|
|
(when vscroll?
|
|
(on-scroll-change SB_VERT wParam))
|
|
0]
|
|
[else
|
|
(when (= msg WM_GESTURE)
|
|
;; The fall-though wndproc might generate a WM_*SCROLL
|
|
;; event for us, but we need to force an update,
|
|
;; because the generated event happens after the position
|
|
;; is changed. And if it doesn't generate a scroll, then
|
|
;; it's ok to have an occassional spurious update.
|
|
(set! next-scroll-is-change? #t))
|
|
(super wndproc w msg wParam lParam default)]))
|
|
|
|
(define/override (wndproc-for-ctlproc w msg wParam lParam default)
|
|
;; act on clicks for a combo field:
|
|
(if (try-mouse w msg wParam lParam)
|
|
0
|
|
(default w msg wParam lParam)))
|
|
|
|
(set! dc (new dc% [canvas this] [transparent? (memq 'transparent style)]))
|
|
(send dc start-backing-retained)
|
|
|
|
(define/public (get-dc) dc)
|
|
|
|
(define gl-config gl-conf)
|
|
(define/public (get-gl-config) gl-config)
|
|
|
|
(define/override (on-resized)
|
|
(reset-dc))
|
|
|
|
(define/private (reset-dc [refresh? #t])
|
|
(send dc reset-backing-retained)
|
|
(send dc set-auto-scroll
|
|
(if (get-virtual-width)
|
|
(get-virtual-h-pos)
|
|
0)
|
|
(if (get-virtual-height)
|
|
(get-virtual-v-pos)
|
|
0))
|
|
(when refresh? (refresh-one)))
|
|
|
|
(define/override (show-children)
|
|
(when (dc . is-a? . dc<%>)
|
|
;; if the canvas was never shown, then it has never
|
|
;; been refreshed --- but it may have been drawn
|
|
;; outside `on-paint', so force a refresh
|
|
(reset-dc)))
|
|
|
|
(define/override (get-client-hwnd)
|
|
canvas-hwnd)
|
|
|
|
(define/override (set-size x y w h)
|
|
(super set-size x y w h)
|
|
(when panel-hwnd
|
|
(let* ([r (and (or (= w -1) (= h -1))
|
|
(GetWindowRect hwnd))]
|
|
[w (if (= w -1) (->normal (- (RECT-right r) (RECT-left r))) w)]
|
|
[h (if (= h -1) (->normal (- (RECT-bottom r) (RECT-top r))) h)])
|
|
(MoveWindow canvas-hwnd 0 0 (->screen (max 1 (- w COMBO-WIDTH))) (->screen h) #t)
|
|
(MoveWindow combo-hwnd 0 0 (->screen (max 1 w)) (->screen (- h 2)) #t)))
|
|
(when (and (is-auto-scroll?)
|
|
(not (is-panel?)))
|
|
(reset-auto-scroll))
|
|
(on-size))
|
|
|
|
;; this `on-size' method is for `editor-canvas%', only:
|
|
(define/public (on-size) (void))
|
|
|
|
;; The `queue-paint' and `paint-children' methods
|
|
;; are defined by `canvas-mixin' from ../common/canvas-mixin
|
|
(define/public (queue-paint) (void))
|
|
(define/public (request-canvas-flush-delay)
|
|
(request-flush-delay this))
|
|
(define/public (cancel-canvas-flush-delay req)
|
|
(cancel-flush-delay req))
|
|
(define/public (queue-canvas-refresh-event thunk)
|
|
(queue-window-refresh-event this thunk))
|
|
(define/public (skip-pre-paint?) #f)
|
|
|
|
(define/public (get-flush-window) canvas-hwnd)
|
|
|
|
(define/public (begin-refresh-sequence)
|
|
(send dc suspend-flush))
|
|
(define/public (end-refresh-sequence)
|
|
(send dc resume-flush))
|
|
|
|
;; Improve this method to flush locally
|
|
;; instead of globally:
|
|
(define/public (flush)
|
|
(flush-display))
|
|
|
|
(define/public (on-paint) (void))
|
|
(define/override (refresh-one) (queue-paint))
|
|
|
|
(define/public (queue-backing-flush)
|
|
(unless for-gl?
|
|
(InvalidateRect canvas-hwnd #f #f)
|
|
(schedule-periodic-backing-flush)))
|
|
|
|
;; overridden to extend for scheduled periodic flushes:
|
|
(define/public (schedule-periodic-backing-flush)
|
|
(void))
|
|
(define/public (do-canvas-backing-flush hdc)
|
|
(if hdc
|
|
(do-backing-flush this dc hdc)
|
|
(if (positive? paint-suspended)
|
|
;; suspended => try again later
|
|
(schedule-periodic-backing-flush)
|
|
;; not suspended
|
|
(let ([hdc (GetDC canvas-hwnd)])
|
|
(do-backing-flush this dc hdc)
|
|
(ReleaseDC canvas-hwnd hdc)
|
|
;; We'd like to validate the region that
|
|
;; we just updated, so we can potentially
|
|
;; avoid a redundant refresh. For some reason,
|
|
;; vadilation can cancel an update that hasn't
|
|
;; happened, yet; this problem needs further
|
|
;; invesitigation.
|
|
#;
|
|
(ValidateRect canvas-hwnd #f)))))
|
|
|
|
(define/public (make-compatible-bitmap w h)
|
|
(send dc make-backing-bitmap w h))
|
|
|
|
(define paint-suspended 0)
|
|
(define suspended-refresh? #f)
|
|
(define/public (suspend-paint-handling)
|
|
(atomically
|
|
(set! paint-suspended (add1 paint-suspended))))
|
|
(define/public (resume-paint-handling)
|
|
(atomically
|
|
(unless (zero? paint-suspended)
|
|
(set! paint-suspended (sub1 paint-suspended))
|
|
(when (and (zero? paint-suspended)
|
|
suspended-refresh?)
|
|
(set! suspended-refresh? #f)
|
|
(InvalidateRect canvas-hwnd #f #f)))))
|
|
|
|
(define no-autoclear? (memq 'no-autoclear style))
|
|
(define transparent? (memq 'transparent style))
|
|
(define bg-col (make-object color% "white"))
|
|
(define bg-colorref #xFFFFFF)
|
|
(define/public (get-canvas-background) (if transparent?
|
|
#f
|
|
bg-col))
|
|
(define/public (get-canvas-background-for-backing) (and (not transparent?)
|
|
(not no-autoclear?)
|
|
bg-col))
|
|
(define/public (set-canvas-background col)
|
|
(atomically
|
|
(set! bg-col col)
|
|
(set! bg-colorref (make-COLORREF (send col red)
|
|
(send col green)
|
|
(send col blue)))))
|
|
|
|
(define wants-focus? (and (not (is-panel?))
|
|
(not (memq 'no-focus style))))
|
|
(define/override (can-accept-focus?)
|
|
wants-focus?)
|
|
|
|
(define/public (is-panel?) #f)
|
|
|
|
(define h-scroll-visible? hscroll?)
|
|
(define v-scroll-visible? vscroll?)
|
|
(define/public (show-scrollbars h? v?)
|
|
(when hscroll?
|
|
(atomically
|
|
(set! h-scroll-visible? (and h? #t))
|
|
(ShowScrollBar canvas-hwnd SB_HORZ h?)))
|
|
(when vscroll?
|
|
(atomically
|
|
(set! v-scroll-visible? (and v? #t))
|
|
(ShowScrollBar canvas-hwnd SB_VERT v?)))
|
|
(reset-dc))
|
|
|
|
(define/override (do-set-scrollbars h-step v-step
|
|
h-len v-len
|
|
h-page v-page
|
|
h-pos v-pos)
|
|
(define (make-info len page pos vis?)
|
|
(make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
|
|
(bitwise-ior (if vis? SIF_DISABLENOSCROLL 0)
|
|
SIF_RANGE
|
|
SIF_POS
|
|
SIF_PAGE)
|
|
0 (+ len page -1) page pos 0))
|
|
(when hscroll?
|
|
(SetScrollInfo canvas-hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t))
|
|
(when vscroll?
|
|
(SetScrollInfo canvas-hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t))
|
|
(void))
|
|
|
|
(define/override (reset-dc-for-autoscroll)
|
|
(reset-dc)
|
|
(refresh-one))
|
|
|
|
(define/override (get-virtual-h-pos)
|
|
(GetScrollPos canvas-hwnd SB_HORZ))
|
|
(define/override (get-virtual-v-pos)
|
|
(GetScrollPos canvas-hwnd SB_VERT))
|
|
|
|
(define/private (is-disabled-scroll-dir? which)
|
|
(or (if (eq? which 'vertical)
|
|
(not vscroll?)
|
|
(not hscroll?))
|
|
(is-disabled-scroll?)))
|
|
|
|
(define/public (get-scroll-pos which)
|
|
(if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
|
|
0
|
|
(GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))))
|
|
(define/public (get-scroll-range which)
|
|
(if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
|
|
0
|
|
(get-real-scroll-range which)))
|
|
(define/public (get-real-scroll-range which)
|
|
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
|
|
(+ (- (SCROLLINFO-nMax i)
|
|
(SCROLLINFO-nPage i))
|
|
1)))
|
|
(define/public (get-scroll-page which)
|
|
(if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
|
|
0
|
|
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
|
|
(SCROLLINFO-nPage i))))
|
|
|
|
(define/public (set-scroll-pos which v)
|
|
(void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t)))
|
|
(define/public (set-scroll-range which v)
|
|
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
|
|
(set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE
|
|
(if (if (eq? which 'vertical)
|
|
v-scroll-visible?
|
|
h-scroll-visible?)
|
|
SIF_DISABLENOSCROLL
|
|
0)))
|
|
(set-SCROLLINFO-nMax! i (+ v (SCROLLINFO-nPage i) -1))
|
|
(SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)
|
|
(void)))
|
|
(define/public (set-scroll-page which v)
|
|
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
|
|
(set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE
|
|
(if (if (eq? which 'vertical)
|
|
v-scroll-visible?
|
|
h-scroll-visible?)
|
|
SIF_DISABLENOSCROLL
|
|
0)))
|
|
(set-SCROLLINFO-nMax! i (+ (- (SCROLLINFO-nMax i) (SCROLLINFO-nPage i))
|
|
v))
|
|
(set-SCROLLINFO-nPage! i v)
|
|
(SetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)
|
|
(void)))
|
|
|
|
(define/public (on-scroll e) (void))
|
|
(define/private (on-scroll-change dir param)
|
|
(let ([i (GetScrollInfo canvas-hwnd dir)])
|
|
(let* ([part (LOWORD param)]
|
|
[forced-pos (and (= part SB_THUMBPOSITION)
|
|
(HIWORD param))]
|
|
[new-pos
|
|
(cond
|
|
[forced-pos forced-pos]
|
|
[(= part SB_TOP) 0]
|
|
[(= part SB_BOTTOM) (SCROLLINFO-nMax i)]
|
|
[(= part SB_LINEUP) (max 0 (sub1 (SCROLLINFO-nPos i)))]
|
|
[(= part SB_LINEDOWN) (min (SCROLLINFO-nMax i) (add1 (SCROLLINFO-nPos i)))]
|
|
[(= part SB_PAGEUP) (max 0 (- (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))]
|
|
[(= part SB_PAGEDOWN) (min (SCROLLINFO-nMax i) (+ (SCROLLINFO-nPos i) (SCROLLINFO-nPage i)))]
|
|
[(= part SB_THUMBTRACK) (SCROLLINFO-nTrackPos i)]
|
|
[else (SCROLLINFO-nPos i)])])
|
|
(unless (and (= new-pos (SCROLLINFO-nPos i))
|
|
(not forced-pos)
|
|
(not next-scroll-is-change?))
|
|
(set! next-scroll-is-change? #f)
|
|
(set-SCROLLINFO-nPos! i new-pos)
|
|
(set-SCROLLINFO-fMask! i SIF_POS)
|
|
(SetScrollInfo canvas-hwnd dir i #t)
|
|
(if (is-auto-scroll?)
|
|
(refresh-for-autoscroll)
|
|
(queue-window-event
|
|
this
|
|
(lambda ()
|
|
(on-scroll (new scroll-event%
|
|
[event-type 'thumb]
|
|
[direction (if (= dir SB_HORZ) 'horizontal 'vertical)]
|
|
[position new-pos])))))
|
|
(constrained-reply (get-eventspace)
|
|
(lambda ()
|
|
(let loop () (pre-event-sync #t) (when (yield) (loop))))
|
|
(void))))))
|
|
|
|
(define/override (wants-mouse-capture? control-hwnd)
|
|
(ptr-equal? canvas-hwnd control-hwnd))
|
|
|
|
(define/override (definitely-wants-event? w msg wParam e)
|
|
(cond
|
|
[(is-panel?) #f]
|
|
[(e . is-a? . key-event%)
|
|
;; All key events to canvas, event for combo:
|
|
#t]
|
|
[(and (or (= wParam HTVSCROLL)
|
|
(= wParam HTHSCROLL))
|
|
(or (= msg WM_NCLBUTTONDOWN)
|
|
(= msg WM_NCRBUTTONDOWN)
|
|
(= msg WM_NCMBUTTONDOWN)
|
|
(= msg WM_NCLBUTTONDBLCLK)
|
|
(= msg WM_NCRBUTTONDBLCLK)
|
|
(= msg WM_NCMBUTTONDBLCLK)
|
|
(= msg WM_NCLBUTTONUP)
|
|
(= msg WM_NCRBUTTONUP)
|
|
(= msg WM_NCMBUTTONUP)))
|
|
;; let scrollbar handle event:
|
|
#f]
|
|
[else
|
|
;; otherwise, just handle events to canvas:
|
|
(ptr-equal? w canvas-hwnd)]))
|
|
|
|
(define/public (on-combo-select i) (void))
|
|
(define/public (set-combo-text s) (void))
|
|
(define/public (append-combo-item s)
|
|
(SendMessageW/str combo-hwnd CB_ADDSTRING 0 s))
|
|
(define/public (clear-combo-items)
|
|
(SendMessageW combo-hwnd CB_RESETCONTENT 0 0))
|
|
|
|
(define/public (on-popup) (void))
|
|
|
|
(define/override (is-command? cmd)
|
|
(or (= cmd CBN_SELENDOK)
|
|
(= cmd CBN_DROPDOWN)))
|
|
|
|
(define/override (do-command cmd control-hwnd)
|
|
(cond
|
|
[(= cmd CBN_SELENDOK)
|
|
(let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)])
|
|
(queue-window-event this (lambda () (on-combo-select i))))]
|
|
[(= cmd CBN_DROPDOWN)
|
|
(constrained-reply (get-eventspace) (lambda () (on-popup)) (void))]))
|
|
|
|
(define/public (popup-combo)
|
|
(SendMessageW combo-hwnd CB_SHOWDROPDOWN 1 0))
|
|
|
|
(define/override (is-hwnd? a-hwnd)
|
|
(or (ptr-equal? panel-hwnd a-hwnd)
|
|
(ptr-equal? canvas-hwnd a-hwnd)
|
|
(ptr-equal? combo-hwnd a-hwnd)))
|
|
|
|
(define/public (scroll x y)
|
|
(when (is-auto-scroll?)
|
|
(when (x . >= . 0)
|
|
(set-scroll-pos 'horizontal
|
|
(->long (* x (get-real-scroll-range 'horizontal)))))
|
|
(when (y . >= . 0)
|
|
(set-scroll-pos 'vertical
|
|
(->long (* y (get-real-scroll-range 'vertical)))))
|
|
(refresh-for-autoscroll)))
|
|
|
|
(define/public (set-resize-corner on?)
|
|
(void))
|
|
|
|
(define reg-blits null)
|
|
|
|
(define/private (register-one-blit x y w h on-hbitmap off-hbitmap)
|
|
(atomically
|
|
(let ([hdc (create-gc-dc canvas-hwnd)])
|
|
(let ([r (scheme_add_gc_callback
|
|
(make-gc-show-desc hdc on-hbitmap x y w h)
|
|
(make-gc-hide-desc hdc off-hbitmap x y w h))])
|
|
(cons hdc r)))))
|
|
|
|
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
|
(let ([on (fix-bitmap-size on w h on-x on-y)]
|
|
[off (fix-bitmap-size off w h off-x off-y)])
|
|
(let ([on-hbitmap (bitmap->hbitmap on)]
|
|
[off-hbitmap (bitmap->hbitmap off)])
|
|
(atomically
|
|
(set! reg-blits (cons (register-one-blit x y w h on-hbitmap off-hbitmap) reg-blits))))))
|
|
|
|
(define/public (unregister-collecting-blits)
|
|
(atomically
|
|
(for ([r (in-list reg-blits)])
|
|
(ReleaseDC canvas-hwnd (car r))
|
|
(scheme_remove_gc_callback (cdr r)))
|
|
(set! reg-blits null))))))
|
|
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define canvas-panel%
|
|
(class (panel-mixin canvas%)
|
|
(inherit get-content-hwnd
|
|
get-client-hwnd
|
|
get-virtual-h-pos
|
|
get-virtual-v-pos)
|
|
|
|
(define/override (is-panel?) #t)
|
|
|
|
(define/override (notify-child-extent x y)
|
|
(let* ([content-hwnd (get-content-hwnd)]
|
|
[r (GetWindowRect content-hwnd)]
|
|
[w (->normal (- (RECT-right r) (RECT-left r)))]
|
|
[h (->normal (- (RECT-bottom r) (RECT-top r)))])
|
|
(when (or (> x w) (> y h))
|
|
(let ([pr (GetWindowRect (get-client-hwnd))])
|
|
(MoveWindow content-hwnd
|
|
(- (RECT-left r) (RECT-left pr))
|
|
(- (RECT-top r) (RECT-top pr))
|
|
(->screen (max w x)) (->screen (max y h))
|
|
#t)))))
|
|
|
|
(define/override (reset-dc-for-autoscroll)
|
|
(super reset-dc-for-autoscroll)
|
|
(let* ([content-hwnd (get-content-hwnd)]
|
|
[r (GetWindowRect content-hwnd)]
|
|
[w (- (RECT-right r) (RECT-left r))]
|
|
[h (- (RECT-bottom r) (RECT-top r))])
|
|
(MoveWindow content-hwnd
|
|
(->screen (- (get-virtual-h-pos)))
|
|
(->screen (- (get-virtual-v-pos)))
|
|
w h
|
|
#t)))
|
|
|
|
(super-new)))
|