Rename grf -> graphics.
Full names are better.
This commit is contained in:
Brad Nelson
178
windows/graphics.fs
Normal file
178
windows/graphics.fs
Normal file
@ -0,0 +1,178 @@
|
||||
\ Copyright 2022 Bradley D. Nelson
|
||||
\
|
||||
\ Licensed under the Apache License, Version 2.0 (the "License");
|
||||
\ you may not use this file except in compliance with the License.
|
||||
\ You may obtain a copy of the License at
|
||||
\
|
||||
\ http://www.apache.org/licenses/LICENSE-2.0
|
||||
\
|
||||
\ Unless required by applicable law or agreed to in writing, software
|
||||
\ distributed under the License is distributed on an "AS IS" BASIS,
|
||||
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
\ See the License for the specific language governing permissions and
|
||||
\ limitations under the License.
|
||||
|
||||
( Expand Graphics for Windows )
|
||||
|
||||
graphics internals definitions
|
||||
also windows
|
||||
|
||||
z" GrfClass" constant GrfClassName
|
||||
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
|
||||
cell allocate throw to backbuffer
|
||||
|
||||
: 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 negate binfo ->bmiHeader ->biHeight !
|
||||
1 binfo ->bmiHeader ->biPlanes !
|
||||
32 binfo ->bmiHeader ->biBitCount !
|
||||
BI_RGB binfo ->bmiHeader ->biCompression !
|
||||
RESIZED to event
|
||||
;
|
||||
|
||||
: msg>button ( n -- n )
|
||||
dup WM_LBUTTONDOWN = over WM_LBUTTONUP = or if
|
||||
drop LEFT-BUTTON exit
|
||||
then
|
||||
dup WM_MBUTTONDOWN = over WM_MBUTTONUP = or if
|
||||
drop MIDDLE-BUTTON exit
|
||||
then
|
||||
dup WM_RBUTTONDOWN = over WM_RBUTTONUP = or if
|
||||
drop RIGHT-BUTTON exit
|
||||
then
|
||||
drop 0
|
||||
;
|
||||
|
||||
: msg>pressed ( n -- 0/1 )
|
||||
dup WM_LBUTTONDOWN =
|
||||
over WM_MBUTTONDOWN = or
|
||||
over WM_RBUTTONDOWN = or if drop 1 exit then
|
||||
drop 0
|
||||
;
|
||||
|
||||
: GrfWindowProc { hwnd msg w l }
|
||||
WM_DESTROY msg = if
|
||||
0 PostQuitMessage
|
||||
0 exit
|
||||
then
|
||||
WM_PAINT msg = if
|
||||
hwnd ps BeginPaint 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_SYSKEYDOWN msg =
|
||||
WM_KEYDOWN msg = or if
|
||||
w 0 max 255 min to last-key
|
||||
1 last-key key-state!
|
||||
PRESSED to event
|
||||
last-key VK_ALT = if 0 exit then
|
||||
then
|
||||
WM_SYSKEYUP msg =
|
||||
WM_KEYUP msg = or if
|
||||
w 0 max 255 min to last-key
|
||||
0 last-key key-state!
|
||||
RELEASED to event
|
||||
last-key VK_ALT = if 0 exit then
|
||||
then
|
||||
WM_CHAR msg = if
|
||||
w to last-char
|
||||
TYPED to event
|
||||
0 exit
|
||||
then
|
||||
msg msg>button if
|
||||
l GET_X_LPARAM to mouse-x
|
||||
l GET_Y_LPARAM to mouse-y
|
||||
msg msg>button to last-key
|
||||
msg msg>pressed dup last-key key-state!
|
||||
if PRESSED else RELEASED then to event
|
||||
0 exit
|
||||
then
|
||||
WM_MOUSEMOVE msg = if
|
||||
l GET_X_LPARAM to mouse-x
|
||||
l GET_Y_LPARAM to mouse-y
|
||||
MOTION to event
|
||||
0 exit
|
||||
then
|
||||
hwnd msg w l DefWindowProcA
|
||||
;
|
||||
|
||||
graphics definitions
|
||||
also internals
|
||||
also windows
|
||||
|
||||
: window { width height }
|
||||
width 0< { fullscreen }
|
||||
fullscreen if 640 to width 480 to height then
|
||||
|
||||
NULL GetModuleHandleA to hinstance
|
||||
1 1 rescale
|
||||
|
||||
pad WINDCLASSA erase
|
||||
WindowProcShim pad ->lpfnWndProc !
|
||||
hinstance pad ->hInstance !
|
||||
GrfClassName pad ->lpszClassName !
|
||||
NULL IDC_ARROW LoadCursorA pad ->hCursor !
|
||||
hinstance IDI_MAIN_ICON LoadIconA pad ->hIcon !
|
||||
pad RegisterClassA to GrfClass
|
||||
|
||||
0 GrfClass GrfWindowTitle WS_OVERLAPPEDWINDOW
|
||||
CW_USEDEFAULT CW_USEDEFAULT width height
|
||||
NULL NULL hinstance ['] GrfWindowProc callback
|
||||
CreateWindowExA to hwnd
|
||||
|
||||
hwnd GetDC to hdc
|
||||
|
||||
fullscreen if SW_SHOWMAXIMIZED else SW_SHOWDEFAULT then
|
||||
hwnd swap 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
|
||||
IDLE to event
|
||||
msgbuf NULL 0 0 PM_REMOVE PeekMessageA if
|
||||
WM_QUIT msgbuf ->message @ = if
|
||||
FINISHED to event
|
||||
exit
|
||||
then
|
||||
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
|
||||
;
|
||||
|
||||
only forth definitions
|
||||
Reference in New Issue
Block a user