44 lines
1.2 KiB
Racket
44 lines
1.2 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"wndclass.rkt")
|
|
|
|
(provide
|
|
(protect-out scheme_add_gc_callback
|
|
scheme_remove_gc_callback
|
|
create-gc-dc
|
|
make-gc-show-desc
|
|
make-gc-hide-desc))
|
|
|
|
(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
|
|
(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
|
|
|
|
(define-gdi32 BitBlt/raw _fpointer
|
|
#;
|
|
(_wfun _HDC _int _int _int _int _HDC _int _int _DWORD -> _BOOL)
|
|
#:c-id BitBlt)
|
|
(define-gdi32 SelectObject/raw _fpointer
|
|
#:c-id SelectObject)
|
|
|
|
(define SRCCOPY #x00CC0020)
|
|
|
|
(define blit-hdc (CreateCompatibleDC #f))
|
|
|
|
(define (create-gc-dc hwnd)
|
|
(GetDC hwnd))
|
|
|
|
(define (make-draw hdc hbitmap x y w h)
|
|
(vector
|
|
(vector 'osapi_ptr_ptr->void SelectObject/raw blit-hdc hbitmap)
|
|
(vector 'osapi_ptr_int_int_int_int_ptr_int_int_long->void
|
|
BitBlt/raw hdc x y w h blit-hdc 0 0 SRCCOPY)
|
|
(vector 'ptr_ptr->void SelectObject/raw blit-hdc #f)))
|
|
|
|
(define (make-gc-show-desc hdc hbitmap x y w h)
|
|
(make-draw hdc hbitmap x y w h))
|
|
|
|
(define (make-gc-hide-desc hdc hbitmap x y w h)
|
|
(make-draw hdc hbitmap x y w h))
|