Adding grf somewhat for windows.

2022-02-20 21:50:41 -08:00
parent aa40d5375d
commit af44b3c1fd
8 changed files with 152 additions and 23 deletions
--- a/ueforth/common/calling.h
+++ b/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)
--- a/ueforth/common/calls.h
+++ b/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)
--- a/ueforth/common/grf.fs
+++ b/ueforth/common/grf.fs
@ -32,19 +32,29 @@
 \   last-keycode ( -- n )
 \   event ( -- n )
 \ Event constants:
-\   UNKNOWN TIMEOUT RESIZE EXPOSE
-\   MOTION PRESS RELEASE
+\   UNKNOWN TIMEOUT RESIZED EXPOSED
+\   MOTION PRESSED RELEASED FINISHED

 vocabulary grf   grf definitions
 vocabulary internals

 0 constant UNKNOWN
 1 constant TIMEOUT
-2 constant RESIZE
-3 constant EXPOSE
+2 constant RESIZED
+3 constant EXPOSED
 4 constant MOTION
-5 constant PRESS
-6 constant RELEASE
+5 constant PRESSED
+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. )

--- a/ueforth/common/grf_test.fs
+++ b/ueforth/common/grf_test.fs
@ -15,5 +15,16 @@
 grf

 640 480 window
-wait
-bye
+: run
+  begin
+    wait
+    100 0 do
+      50 0 do
+        $ffcc00 i j pixel l!
+      loop
+    loop
+    flip
+  event FINISHED = until
+  bye
+;
+run
--- a/ueforth/windows/grf.fs
+++ b/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
-0 255 0 RGB CreateSolidBrush constant green
-create side RECT allot
-0 side ->left !
-0 side ->top !
-200 side ->right !
-100 side ->bottom !
-
+: rescale { w h }
+  w width = h height = and if exit then
+  w to width   h to height
+  backbuffer w h * 4* resize throw to backbuffer
+  backbuffer w h * 4* 255 fill
+  binfo BITMAPINFO erase
+  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
--- a/ueforth/windows/windows_core.fs
+++ b/ueforth/windows/windows_core.fs
@ -17,11 +17,12 @@ vocabulary windows   windows definitions
 ( DLL Handling )
 create calls
 internals
-' call0 , ' call1 , ' call2 , ' call3 , ' call4 ,  ' call5 ,
-' call6 , ' call7 , ' call8 , ' call9 , ' call10 , ' call11 , ' call12 ,
+ ' call0 ,  ' call1 ,  ' call2 ,  ' call3 ,  ' call4 ,
+ ' 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" -- )
--- a/ueforth/windows/windows_gdi.fs
+++ b/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
--- a/ueforth/windows/windows_user.fs
+++ b/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