needs NoConsole.f
needs MessageLoop.f

true value fsave? \ set to TRUE if you want to save demo.exe

\ Forth doesn't know about C structs, so define some words for defining structs

\ start a named structed
: start-struct ( name -- name-address 0 ) create here cell allot 0 does> @ ;

\ create a field in a struct
: field ( index size name -- index+size ) create over , + does> @ + ;

\ finish the struct
: end-struct ( name-address size -- name-address=size ) swap ! ;

\ struct BITMAPINFOHEADER
start-struct BITMAPINFOHEADER
    4 field biSize
    4 field biWidth
    4 field biHeight
    2 field biPlanes
    2 field biBitCount
    4 field biCompression
    4 field biSizeImage
    4 field biXPelsPerMeter
    4 field biYPelsPerMeter
    4 field biClrUsed
    4 field biClrImportant
end-struct

\ struct RECT
start-struct RECT
    4 field left
    4 field top
    4 field right
    4 field bottom
end-struct

\ constants
750 constant width
400 constant height
$ffffff constant background-color

\ variables
create paintstruct 64 allot
create bmi BITMAPINFOHEADER allot
variable framebuffer-pointer
0 value framebuffer-dc
0 value framebuffer
0 value framebuffer-bitmap
variable temp_hdc
0 value main-wnd
create temp-rect RECT allot

: create-framebuffer
    \ clear BITMAPINFOHEADER
	bmi BITMAPINFOHEADER 0 fill

    \ init BITMAPINFOHEADER
	BITMAPINFOHEADER bmi biSize !
	width bmi biWidth !
	height negate bmi biHeight !
	1 bmi biPlanes w!
	32 bmi biBitCount w!
	BI_RGB bmi biCompression !

    \ create offscreen DC
    0 call CreateCompatibleDC to framebuffer-dc
    0 0 framebuffer-pointer DIB_RGB_COLORS bmi framebuffer-dc call CreateDIBSection to framebuffer-bitmap
    framebuffer-pointer @ to framebuffer
    MM_TEXT framebuffer-dc call SetMapMode drop
    framebuffer-bitmap framebuffer-dc call SelectObject drop ;

\ clear offscreen framebuffer
: clear ( -- )
    0 temp-rect top !
    0 temp-rect left !
    width temp-rect right !
    height temp-rect bottom !
    background-color call CreateSolidBrush dup
    temp-rect framebuffer-dc call FillRect drop
    DeleteObject drop ;

\ move current drawing position to the specified coordinates
: move-to { x y -- } 0 y x framebuffer-dc call MoveToEx drop ;

\ draw line from current drawing position to the specified position
: line-to { x y -- } y x framebuffer-dc call LineTo drop ;

\ Windows WM_PAINT event handler
: on-paint  ( -- result )
    paintstruct main-wnd call BeginPaint temp_hdc !
    SRCCOPY 0 0 framebuffer-dc height width 0 0 temp_hdc @ call BitBlt drop
    paintstruct main-wnd call EndPaint drop 0 ;

: (strlen) ( addr offset -- len )
    over c@ if swap 1+ swap 1+ recurse else swap drop then ;

: strlen ( addr -- len )
    0 (strlen) ;

200 constant edit-height
50 value button-width
width button-width - 2 / value edit-width
0 value input-wnd
0 value output-wnd
0 value button-wnd
101 constant input-id
102 constant output-id
103 constant button-id

: adjust-size
    temp-rect main-wnd GetClientRect
    0
    height edit-height + 2 * temp-rect bottom @ temp-rect top @ - -
    width 2 * temp-rect right @ temp-rect left @ - -
    0
    0
    main-wnd
    call MoveWindow drop ;

: create-button { x y width height id }
    0 AppInst id main-wnd height width y x
    WS_VISIBLE WS_CHILD or WS_BORDER or z" Run" z" BUTTON" 0 CreateWindowEx ;

: create-edit { x y width height id }
    0 AppInst id main-wnd height width y x
    WS_VISIBLE WS_CHILD or WS_BORDER or ES_LEFT or ES_MULTILINE or ES_WANTRETURN or WS_VSCROLL or
    z" " z" EDIT" 0 CreateWindowEx ;

: add-input-text ( z-text -- )
    0 -1 EM_SETSEL input-wnd SendMessage drop
    1 EM_REPLACESEL input-wnd SendMessage drop ;

: add-input-line ( z-text -- )
    add-input-text
    z" \n" add-input-text ;

: demo-program z"
    z" 50 constant line-count" add-input-line
    z" " add-input-line
    z" : draw-some-lines ( -- )" add-input-line
    z"     line-count 0 do" add-input-line
    z"         width i * line-count / 0 move-to" add-input-line
    z"         0 height height i * line-count / - line-to" add-input-line
    z"     loop" add-input-line
    z"     repaint ;" add-input-line
    z" " add-input-line
    z" draw-some-lines" add-input-line
    z" " add-input-line ;

\ Windows WM_CREATE event handler
: on-create ( -- result )
    adjust-size
    0 height edit-width edit-height input-id create-edit to input-wnd
    demo-program
    edit-width height button-width edit-height button-id create-button to button-wnd
    edit-width button-width + height edit-width edit-height output-id create-edit to output-wnd ;

: repaint 0 0 main-wnd Call InvalidateRect drop ;

fsave? [if]
: on-destroy ( -- result ) Call PostQuitMessage drop 0 ;
[else]
: on-destroy ( -- result ) 0 ;
[then]


0 value line-drawing

: on-mousemove ( x y -- ) line-drawing if line-to repaint else 2drop then ;

: on-lbuttondown ( x y -- ) move-to 1 to line-drawing ;

: on-lbuttonup ( x y -- ) 0 to line-drawing ;

: mouse-param-to-x-y ( lparam -- x y ) dup $ffff and swap 16 rshift $ffff and ;

0 value text-length
0 value text-buffer

: add-output-text ( z-text -- )
    output-wnd if
        0 -1 EM_SETSEL output-wnd SendMessage drop
        1 EM_REPLACESEL output-wnd SendMessage drop
    then ;

: eval-input-text ( -- )
    0 0 WM_GETTEXTLENGTH input-wnd SendMessage 1+ to text-length
    text-length allocate drop to text-buffer
    text-length text-buffer input-wnd call GetWindowText drop
    text-buffer dup strlen evaluate s" ok" type cr
    text-buffer free drop ;

: on-command ( id -- )
    case
        button-id of
            eval-input-text endof
        ( default )
                exit
        endcase ;

\ Windows event handler
: window-proc  { hWnd msg wParam lParam -- result }
    hWnd to main-wnd
    msg case
        WM_CREATE of
                on-create 0 endof
        WM_PAINT of
                on-paint 0 endof
        WM_DESTROY of
                on-destroy 0 endof
        WM_MOUSEMOVE of
                lParam mouse-param-to-x-y on-mousemove 0 endof
        WM_LBUTTONDOWN of
                lParam mouse-param-to-x-y on-lbuttondown 0 endof
        WM_LBUTTONUP of
                lParam mouse-param-to-x-y on-lbuttonup 0 endof
        WM_COMMAND of
                wParam $ffff and on-command 0 endof
        ( default )
                drop lParam wParam msg hWnd call DefWindowProc exit
        endcase ;

\ define as a callback function
4 callback the-window-proc window-proc

\ register Window class
: window-class-name z" ForthApplicationWnd" ;
: register-class
    here
	CS_HREDRAW CS_VREDRAW or ,
        the-window-proc ,
        0 ,
        0 ,
        AppInst ,
        0 ,
        IDC_ARROW 0 call LoadCursor ,
        0 ,
        0 ,
        window-class-name ,
    call RegisterClass drop ;

fsave? [if]
: parent-window 0 ;
[else]
: parent-window ConHndl ;
[then]

\ create Window
: create-window ( -- hwnd )
    0 AppInst 0 parent-window
    height edit-height +
    width
    0 ( y )
    0 ( x )
    WS_VISIBLE WS_OVERLAPPEDWINDOW or
        WS_MAXIMIZEBOX -1 xor and
        WS_MINIMIZEBOX -1 xor and
        WS_SIZEBOX -1 xor and
    z" Forth Demo"
    window-class-name
    0
    call CreateWindowEx ;

: init-windows ( -- )
    create-framebuffer
    clear
    register-class
    create-window dup
    SW_SHOW swap call ShowWindow drop
    call UpdateWindow drop ;

fsave? [if]
create char-buf 2 allot
: wnd-emit ( char -- )
    char-buf c!
    0 char-buf 1+ c!
    char-buf add-output-text ;

: wnd-type ( addr length -- )
    dup if over + swap do i c@ wnd-emit loop else drop then ;

: wnd-cr z" \n" add-output-text ;

: window-output
        ['] wnd-emit is emit
        ['] wnd-type is type
        ['] wnd-cr is cr ;

' window-output is console

: start
        init-windows
        window-output
        MessageLoop bye ;
[else]
: start init-windows ;
[then]

fsave? [if]
        \ Setup the Console I/O for an application without the console window.
        NoConsoleIO

        \ Tell Imageman that we don't need the w32fconsole.dll.
        NoConsoleInImage

        \ Create the exe-file
        0 0 ' start application demo

        1 pause-seconds bye
[else]
        start
[then]
