needs NoConsole.f needs MessageLoop.f false 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 ; \ plots a point : plot ( x y -- ) 2dup move-to 1+ line-to ; \ 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]