Adding grf somewhat for windows.

ueforth/common/calling.h

@@ -27,6 +27,9 @@
 #define n10 sp[-9]
 #define n11 sp[-10]
 #define n12 sp[-11]
+#define n13 sp[-12]
+#define n14 sp[-13]
+#define n15 sp[-14]
 
 #define a0 ((void *) tos)
 #define a1 (*(void **) &n1)

ueforth/common/calls.h

@@ -37,4 +37,7 @@ typedef cell_t (CALLTYPE *call_t)();
   YV(internals, CALL9, n0 = ct0(n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 9) \
   YV(internals, CALL10, n0 = ct0(n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 10) \
   YV(internals, CALL11, n0 = ct0(n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 11) \
-  YV(internals, CALL12, n0 = ct0(n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 12)
+  YV(internals, CALL12, n0 = ct0(n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 12) \
+  YV(internals, CALL13, n0 = ct0(n13, n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 13) \
+  YV(internals, CALL14, n0 = ct0(n14, n13, n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 14) \
+  YV(internals, CALL15, n0 = ct0(n15, n14, n13, n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 15)

ueforth/common/grf.fs

@@ -32,19 +32,29 @@
 \   last-keycode ( -- n )
 \   event ( -- n )
 \ Event constants:
-\   UNKNOWN TIMEOUT RESIZE EXPOSE
+\   UNKNOWN TIMEOUT RESIZED EXPOSED
-\   MOTION PRESS RELEASE
+\   MOTION PRESSED RELEASED FINISHED
 
 vocabulary grf   grf definitions
 vocabulary internals
 
 0 constant UNKNOWN
 1 constant TIMEOUT
-2 constant RESIZE
+2 constant RESIZED
-3 constant EXPOSE
+3 constant EXPOSED
 4 constant MOTION
-5 constant PRESS
+5 constant PRESSED
-6 constant RELEASE
+6 constant RELEASED
+7 constant FINISHED
+
+0 value mouse-x
+0 value mouse-y
+0 value last-key
+0 value last-keysym
+0 value last-keycode
+0 value event
+0 value width
+0 value height
 
 ( Rest of definitions per platform. )
 

ueforth/common/grf_test.fs

@@ -15,5 +15,16 @@
 grf
 
 640 480 window
-wait
+: run
-bye
+  begin
+    wait
+    100 0 do
+      50 0 do
+        $ffcc00 i j pixel l!
+      loop
+    loop
+    flip
+  event FINISHED = until
+  bye
+;
+run

ueforth/windows/grf.fs

@@ -1,4 +1,3 @@
-( ------------------------------------------------------------ )
 \ Copyright 2022 Bradley D. Nelson
 \
 \ Licensed under the Apache License, Version 2.0 (the "License");
@@ -24,30 +23,75 @@ z" uEforth" constant GrfWindowTitle
 0 value hinstance
 0 value GrfClass
 0 value hwnd
+0 value hdc
 create ps PAINTSTRUCT allot
 create msgbuf MSG allot
+create binfo BITMAPINFO allot
+0 value backbuffer
+cell allocate throw to backbuffer
 
-255 192 0 RGB CreateSolidBrush constant orange
+: rescale { w h }
-0 255 0 RGB CreateSolidBrush constant green
+  w width = h height = and if exit then
-create side RECT allot
+  w to width   h to height
-0 side ->left !
+  backbuffer w h * 4* resize throw to backbuffer
-0 side ->top !
+  backbuffer w h * 4* 255 fill
-200 side ->right !
+  binfo BITMAPINFO erase
-100 side ->bottom !
+  BITMAPINFOHEADER binfo ->bmiHeader ->biSize !
-
+  w binfo ->bmiHeader ->biWidth !
+  h binfo ->bmiHeader ->biHeight !
+  1 binfo ->bmiHeader ->biPlanes !
+  32 binfo ->bmiHeader ->biBitCount !
+  BI_RGB binfo ->bmiHeader ->biCompression !
+  RESIZED to event
+;
 
 : GrfWindowProc { hwnd msg w l }
+  WM_QUIT msg = if
+    FINISHED to event
+    0 exit
+  then
   WM_DESTROY msg = if
     0 PostQuitMessage
     0 exit
   then
   WM_PAINT msg = if
     hwnd ps BeginPaint drop
-    ps ->hdc @ ps ->rcPaint orange FillRect drop
-    ps ->hdc @ side green FillRect drop
     hwnd ps EndPaint drop
+    EXPOSED to event
     0 exit
   then
+  WM_SIZE msg = if
+    l GET_X_LPARAM $ffff and
+    l GET_Y_LPARAM $ffff and rescale
+    0 exit
+  then
+  WM_KEYDOWN msg = if
+    l GET_X_LPARAM to mouse-x
+    l GET_Y_LPARAM to mouse-y
+    PRESSED to event
+  then
+  WM_KEYUP msg = if
+    l GET_X_LPARAM to mouse-x
+    l GET_Y_LPARAM to mouse-y
+    RELEASED to event
+  then
+  WM_CHAR msg = if
+  then
+  WM_LBUTTONDOWN msg = if
+    l GET_X_LPARAM to mouse-x
+    l GET_Y_LPARAM to mouse-y
+    PRESSED to event
+  then
+  WM_LBUTTONUP msg = if
+    l GET_X_LPARAM to mouse-x
+    l GET_Y_LPARAM to mouse-y
+    RELEASED to event
+  then
+  WM_MOUSEMOVE msg = if
+    l GET_X_LPARAM to mouse-x
+    l GET_Y_LPARAM to mouse-y
+    MOTION to event
+  then
   hwnd msg w l DefWindowProcA
 ;
 
@@ -57,6 +101,7 @@ also windows
 
 : window { width height }
   NULL GetModuleHandleA to hinstance
+  1 1 rescale
 
   pad WINDCLASSA erase
     WindowProcShim pad ->lpfnWndProc !
@@ -71,15 +116,36 @@ also windows
     NULL NULL hinstance ['] GrfWindowProc callback
     CreateWindowExA to hwnd
 
+  hwnd GetDC to hdc
+
   hwnd SW_SHOWMAXIMIZED ShowWindow drop
   hwnd SetForegroundWindow drop
 ;
 
 : wait
+  event FINISHED = if exit then
+  FINISHED to event
   begin msgbuf NULL 0 0 GetMessageA while
     msgbuf TranslateMessage drop
     msgbuf DispatchMessageA drop
+    event FINISHED <> if exit then
   repeat
 ;
 
+: poll
+  event FINISHED = if exit then
+  UNKNOWN to event
+  msgbuf NULL 0 0 PM_REMOVE PeekMessageA if
+    msgbuf TranslateMessage drop
+    msgbuf DispatchMessageA drop
+  then
+;
+
+: flip
+  hdc 0 0 width height 0 0 width height
+    backbuffer binfo DIB_RGB_COLORS SRCCOPY StretchDIBits drop
+;
+
+: pixel ( w h -- a ) width * + 4* backbuffer + ;
+
 only forth definitions

ueforth/windows/windows_core.fs

@@ -17,11 +17,12 @@ vocabulary windows   windows definitions
 ( DLL Handling )
 create calls
 internals
-' call0 , ' call1 , ' call2 , ' call3 , ' call4 ,  ' call5 ,
+ ' call0 ,  ' call1 ,  ' call2 ,  ' call3 ,  ' call4 ,
-' call6 , ' call7 , ' call8 , ' call9 , ' call10 , ' call11 , ' call12 ,
+ ' call5 ,  ' call6 ,  ' call7 ,  ' call8 ,  ' call9 ,
+' call10 , ' call11 , ' call12 , ' call13 , ' call14 , ' call15 ,
 windows
 : sofunc ( z n a "name" -- )
-   >r dup 12 > throw r> ( Check there aren't too many args )
+   >r dup 15 > throw r> ( Check there aren't too many args )
    swap >r swap GetProcAddress dup 0= throw create , r> cells calls + @ ,
    does> dup @ swap cell+ @ execute ;
 : dll ( z "name" -- )

ueforth/windows/windows_gdi.fs

@@ -44,4 +44,31 @@ $80000011 constant DEFAULT_GUI_FONT
 $80000012 constant DC_BRUSH
 $80000013 constant DC_PEN
 
+z" StretchDIBits" 13 Gdi32 StretchDIBits
+struct RGBQUAD
+  i8 field ->rgbBlue
+  i8 field ->rgbGreen
+  i8 field ->rgbRed
+  i8 field ->rgbReserved
+struct BITMAPINFOHEADER
+  i16 field ->biSize
+  i32 field ->biWidth
+  i32 field ->biHeight
+  i16 field ->biPlanes
+  i16 field ->biBitCount
+  i32 field ->biCompression
+  i32 field ->biSizeImage
+  i32 field ->biXPelsPerMeter
+  i32 field ->biYPelsPerMeter
+  i32 field ->biClrUsed
+  i32 field ->biClrImportant
+struct BITMAPINFO
+  BITMAPINFOHEADER field ->bmiHeader
+           RGBQUAD field ->bmiColors
+
+0 constant BI_RGB
+0 constant DIB_RGB_COLORS
+
+$00cc0020 constant SRCCOPY
+
 only forth definitions

ueforth/windows/windows_user.fs

@@ -106,6 +106,7 @@ struct RECT
   i32 field ->bottom
 
 z" GetMessageA" 4 User32 GetMessageA
+z" PeekMessageA" 5 User32 PeekMessageA
 z" TranslateMessage" 1 User32 TranslateMessage
 z" DispatchMessageA" 1 User32 DispatchMessageA
 struct MSG
@@ -116,7 +117,11 @@ struct MSG
     i32 field ->time
    POINT field ->pt
     i32 field ->lPrivate
+0 constant PM_NOREMOVE
+1 constant PM_REMOVE
+2 constant PM_NOYIELD
 
+z" GetDC" 1 User32 GetDC
 z" BeginPaint" 2 User32 BeginPaint
 z" EndPaint" 2 User32 EndPaint
 struct PAINTSTRUCT
@@ -160,4 +165,7 @@ IDI_EXCLAMATION constant IDI_WARNING
 IDI_HAND constant IDI_ERROR
 IDI_ASTERISK constant IDI_INFORMATION
 
+: GET_Y_LPARAM ( n -- n ) >r rp@ 2 + sw@ rdrop ;
+: GET_X_LPARAM ( n -- n ) >r rp@ sw@ rdrop ;
+
 only forth definitions