#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" "theme.rkt") (provide canvas%) (define WS_EX_STATICEDGE #x00020000) (define WS_EX_CLIENTEDGE #x00000200) (define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC)) (define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL)) (define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL) -> (unless r (failed 'ShowScrollbar)))) (define _HRGN _pointer) (define-user32 GetDCEx (_wfun _HWND _HRGN _DWORD -> _HDC)) (define DCX_WINDOW #x00000001) (define EP_EDITTEXT 1) (define ETS_NORMAL 1) (define ETS_DISABLE 4) (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 (error 'GetScrollInfo "failed")))) (define COMBO-WIDTH 18) (define canvas% (canvas-mixin (class (item-mixin window%) (init parent x y w h style [ignored-name #f] [gl-config #f]) (inherit get-hwnd get-client-size get-eventspace set-control-font subclass-control) (define hscroll? (memq 'hscroll style)) (define vscroll? (memq 'vscroll style)) (define panel-hwnd (and (memq 'combo style) (CreateWindowExW 0 "PLTTabPanel" #f (bitwise-ior WS_CHILD) 0 0 w h (send parent get-client-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 w h (or panel-hwnd (send parent get-hwnd)) #f hInstance #f)) (define combo-hwnd (and panel-hwnd (CreateWindowExW 0 "PLTCOMBOBOX" "" (bitwise-ior WS_CHILD WS_VISIBLE CBS_DROPDOWNLIST WS_HSCROLL WS_VSCROLL WS_BORDER WS_CLIPSIBLINGS) 0 0 w h panel-hwnd #f hInstance #f))) (define hwnd (or panel-hwnd canvas-hwnd)) (super-new [parent parent] [hwnd hwnd] [extra-hwnds (if panel-hwnd (list canvas-hwnd combo-hwnd) null)] [style style]) (when combo-hwnd (set-control-font #f combo-hwnd) (subclass-control combo-hwnd)) (define control-border-theme (and (memq 'control-border style) (OpenThemeData canvas-hwnd "Edit"))) (define/override (wndproc w msg wParam lParam default) (cond [(= msg WM_PAINT) (let* ([ps (malloc 128)] [hdc (BeginPaint w ps)]) (unless (positive? paint-suspended) (unless (do-backing-flush this dc hdc) (queue-paint)) (do-backing-flush this dc hdc)) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) (if control-border-theme (let* ([r (GetWindowRect canvas-hwnd)] [res (default w msg wParam lParam)] [hdc (GetDCEx canvas-hwnd #f DCX_WINDOW)] [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) (on-scroll-change SB_HORZ (LOWORD wParam)) 0] [(= msg WM_VSCROLL) (on-scroll-change SB_VERT (LOWORD wParam)) 0] [else (super wndproc w msg wParam lParam default)])) (define/override (wndproc-for-ctlproc w msg wParam lParam default) (default w msg wParam lParam)) (define dc (new dc% [canvas this])) (send dc start-backing-retained) (define/public (get-dc) dc) (define/override (on-resized) (send dc reset-backing-retained)) (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) (- (RECT-right r) (RECT-left r)) w)] [h (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)]) (MoveWindow canvas-hwnd 0 0 (max 1 (- w COMBO-WIDTH)) h #t) (MoveWindow combo-hwnd 0 0 (max 1 w) (- h 2) #t)))) ;; 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 (get-flush-window) canvas-hwnd) (define/public (begin-refresh-sequence) (send dc suspend-flush)) (define/public (end-refresh-sequence) (send dc resume-flush)) (define/public (on-paint) (void)) (define/override (refresh) (queue-paint)) (define/public (queue-backing-flush) (InvalidateRect canvas-hwnd #f #f)) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) (define paint-suspended 0) (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))))) (define/public (get-virtual-size w h) (get-client-size w h)) (define transparent? (memq 'transparent style)) (define bg-col (make-object color% "white")) (define/public (get-canvas-background) (if transparent? #f bg-col)) (define/public (set-canvas-background col) (set! bg-col col)) (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?)))) (define/public (set-scrollbars h-step v-step h-len v-len h-page v-page h-pos v-pos auto?) (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))) (def/public-unimplemented set-background-to-gray) (define/public (get-scroll-pos which) (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) (define/public (get-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) (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))) (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))) (define/public (on-scroll e) (void)) (define/private (on-scroll-change dir part) (let ([i (GetScrollInfo canvas-hwnd dir)]) (let ([new-pos (cond [(= 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 (= new-pos (SCROLLINFO-nPos i)) (set-SCROLLINFO-nPos! i new-pos) (set-SCROLLINFO-fMask! i SIF_POS) (SetScrollInfo canvas-hwnd dir i #t) (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 (definitely-wants-event? w e) (or (e . is-a? . key-event%) (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/override (is-command? cmd) (= cmd CBN_SELENDOK)) (define/public (do-command control-hwnd) (let ([i (SendMessageW combo-hwnd CB_GETCURSEL 0 0)]) (queue-window-event this (lambda () (on-combo-select i))))) (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))) (def/public-unimplemented scroll) (def/public-unimplemented warp-pointer) (def/public-unimplemented view-start) (define/public (set-resize-corner on?) (void)))))