;;;; hellowin.scm - Taken straight from Petzold's book - felix


;;; A foreign type for HWND:

(define-foreign-type hwnd c-pointer)


;;; Some constants from `windows.h':

(define-foreign-variable WM_PAINT int "WM_PAINT")
(define-foreign-variable WM_DESTROY int "WM_DESTROY")
(define-foreign-variable SW_SHOWDEFAULT int "SW_SHOWDEFAULT")


;;; Some Windows API functions:

(define show-window (foreign-lambda bool "ShowWindow" hwnd int))
(define update-window (foreign-lambda bool "UpdateWindow" hwnd))
(define post-quit-message (foreign-lambda void "PostQuitMessage" int))
(define def-window-proc (foreign-lambda integer "DefWindowProc" hwnd int integer integer))


;;; Callback procedure:
; 
; - We put this here, so `register-window-class' can see it.

(define-external "CALLBACK" (window_procedure (hwnd hwnd) (int msg) (integer wparam) (integer lparam)) integer
  (cond [(= msg WM_PAINT) (redraw hwnd) 0]
	[(= msg WM_DESTROY) (post-quit-message 0) 0]
	[else (def-window-proc hwnd msg wparam lparam)] ) )


;;; These procedures could theoretically be written in Scheme, but from someone with a lot of time to
;   add all those Win32 bindings. I must admit that I am currently too lazy.

(define register-window-class
  (foreign-lambda* bool () "
    WNDCLASS wc;
    wc.style = CS_HREDRAW | CS_VREDRAW;
    wc.lpfnWndProc = window_procedure;
    wc.cbClsExtra = 0;
    wc.cbWndExtra = 0;
    wc.hInstance = GetModuleHandle(NULL);
    wc.hIcon = LoadIcon(NULL, IDI_APPLICATION);
    wc.hCursor = LoadCursor(NULL, IDC_ARROW);
    wc.hbrBackground = GetStockObject(WHITE_BRUSH);
    wc.lpszMenuName = NULL;
    wc.lpszClassName = \"HelloWin\";
    return(RegisterClass(&wc) != 0);") )

(define create-window
  (foreign-lambda* hwnd ((c-string caption) (int x) (int y) (int w) (int h)) "
    HMODULE me = GetModuleHandle(NULL);
    return(CreateWindow(\"HelloWin\", caption, WS_OVERLAPPEDWINDOW, x, y, w, h, NULL, NULL, me, NULL));") )

(define redraw
  (foreign-lambda* void ((hwnd hwnd)) "
    PAINTSTRUCT ps;
    HDC hdc = BeginPaint(hwnd, &ps);
    RECT r;
    GetClientRect(hwnd, &r);
    DrawText(hdc, \"Hello, Windows!\", -1, &r, DT_SINGLELINE | DT_CENTER | DT_VCENTER);
    EndPaint(hwnd, &ps);") )


;;; Run the message loop:

(define run-message-loop
  (foreign-callback-lambda* void () "
    MSG msg;
    while(GetMessage(&msg, NULL, 0, 0)) {
      TranslateMessage(&msg);
      DispatchMessage(&msg);
    }") )


;;; And go:

(register-window-class)

(define window (create-window "The Hello Program" 100 100 400 300))

(show-window window SW_SHOWDEFAULT)
(update-window window)
(run-message-loop)
