\
\ win.f
\ ----- 
\ - register window classes
\ - poll messages 
\ - exit on 'esc'
\

imp forth.f

\
\ === UTILS =========================================================
\

: loword ( u32 -- u16 ) \ clamp to loword
  0xFFFF and 
;

\
\ === EXIT ==========================================================
\

lib kernel32
sym ExitProcess

: exit ( -- )
  0 ExitProcess vcall
;

\ === WINDOW =========================================================

lib user32
sym RegisterClassA
sym CreateWindowExA
sym PeekMessageA
sym DispatchMessageA
sym DefWindowProcA
sym SetCursor

\
\ --- regClass --------------------------------------------------------------
\

40 con WNDCLASS
4  con WNDCLASS.lpfnWndProc  
36 con WNDCLASS.lpszClassName

: regClass ( -- atom )
  WNDCLASS align here zeromem
  WNDCLASS.lpfnWndProc   DefWindowProcA <!
  WNDCLASS.lpszClassName cstr" t!lt"    <!
  RegisterClassA icall
;

\
\ --- createWin --------------------------------------------------------------
\

0x10000000 con WS_VISIBLE   
0x00000000 con WS_OVERLAPPED
WS_VISIBLE WS_OVERLAPPED or con winStyle

: createWin ( -- hwnd )
  0 0 0 0 WIN_HEIGHT WIN_WIDTH 0 0 winStyle cstr" t!lt" regClass loword 0
  CreateWindowExA icall
;

\
\ --- SetCursor --------------------------------------------------------------
\ 

: win:removeCursor ( -- )
  0 SetCursor vcall
;

\ === WINDOW MESSAGES ==================================================

28   con MSG
 4   con MSG.message 
 8   con MSG.wParam
 
\
\ --- procMsg ----------------------------------------------------------------
\

256  con WM_KEYDOWN
0x1B con VK_ESCAPE

: procMsg ( msg-ptr -- )
      dup  MSG.message <@ WM_KEYDOWN =
      over MSG.wParam  <@ VK_ESCAPE  =
      and
  IF 
    drop exit
  THEN
  DispatchMessageA vcall
;

\ 
\ --- pollMsg ----------------------------------------------------------------
\ 

0x00000001	con	PM_REMOVE

: pollMsg ( -- )
  BEGIN
    PM_REMOVE 0 0 0 here PeekMessageA icall
    0= not
  IF
    here procMsg  
  REPEAT
;

\ 
\ --- entry point ------------------------------------------------------------
\ 

: start
  createWin drop
  BEGIN
    pollMsg
  AGAIN
;