| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 483
» Latest member: aplus
» Forum threads: 2,804
» Forum posts: 26,432
Full Statistics
|
|
|
GPT-4o - BBOX Mouse States - Experiment with a diagram to hint at creation of code. |
|
Posted by: grymmjack - 05-21-2024, 02:18 AM - Forum: Programs
- Replies (10)
|
 |
Chat GPT-4o is pretty damned good and valuable.
I have the free version, and I want to share something pretty great with you all.
First some back story. I created a diagram using draw.io to help me wrap my head around what I need to do to create a reusable marquee selection style (minus the animation) bounding box that can be used as a crop rectangle. The idea is that I will overlay the bounding box on top of an image and use the coordinates X, Y, and width and height of the box vs. it's relative top left location to the image it's overlaid upon to export a section of the image.
I want this to be very similar to like how GIMP does it with a marquee rectangle selection that can be resized, moved, etc.
I also want to write this once and not have to re-write it constantly over and over, hence my idea "BBOX" object, which I will put into my QB64_GJ_LIB, etc. for reuse.
I will use this in my img2ans program which allows people to render raster images down into ANSI text mode, compatible. See the GitHub repo here for an explanation:
grymmjack/img2ans of this program, and it's purpose. Also a little progress dev-blog exists here in the Discussions section of my repo: this explains some of the progression of what I'm working on.
Right, so that out of the way, here is the diagram (you can get the source for this in draw.io format from my repo here; draw.io diagram for BBOX Mouse States. I also created a video to demonstrate that you can use draw.io Visual Studio Code extension to annotate your project by having it hyperlink straight to your source code (any language) here:
OK, that said, here is the diagram in image format:
![[Image: BBOX-state-diag-mouse.png]](https://i.ibb.co/G7WrQZK/BBOX-state-diag-mouse.png)
Then, here is the prompt that I used to ask GPT to explain it:
I uploaded PNG version of BBOX-state-diag-mouse as you see here, and asked:
Can you read this diagram? And explain what it is?
It said the following
GPT Wrote:Yes, I can read and explain this diagram. This is a state machine diagram for "BBOX Mouse States," which outlines the various states and transitions based on mouse interactions with a bounding box (BBOX) in a graphical user interface (GUI). Here's a breakdown of the components and flow:
### Key Components:
1. **States (in red rounded rectangles)**:
- **DESELECTED**: Default state where the BBOX is not selected.
- **OVER**: State when the mouse is hovering over the BBOX.
- **SELECTED**: State when the BBOX is selected.
- **MOVING**: State when the BBOX is being moved.
- **RESIZING**: State when the BBOX is being resized.
- **ZOOMING**: State when zooming actions are performed.
2. **Operations (in dashed rectangles)**:
- **ZOOM IN**: Action performed when zooming in.
- **ZOOM OUT**: Action performed when zooming out.
- **RESIZE FROM LEFT EDGE, RIGHT EDGE, TOP EDGE, BOTTOM EDGE**: Actions for resizing from respective edges.
- **MOVE UP, DOWN, LEFT, RIGHT**: Actions for moving the BBOX in respective directions.
3. **Conditions (in solid rectangles)**:
- **Mouse Over**: Condition when the mouse is over the BBOX.
- **Mouse Out**: Condition when the mouse moves out of the BBOX.
- **Left Click On BBOX**: Condition when a left-click is performed on the BBOX.
- **Left Click Outside BBOX**: Condition when a left-click is performed outside the BBOX.
- **Drag on Left Edge, Right Edge, Top Edge, Bottom Edge**: Conditions for dragging on respective edges.
- **Drag Not on Edge**: Condition for dragging not on the edge but within the BBOX.
- **Drag Up, Down, Left, Right**: Conditions for dragging in respective directions.
- **Wheel Up, Wheel Down**: Conditions for mouse wheel actions.
### Flow Explanation:
1. **Initial State**:
- The diagram starts from the black dot, indicating the initial state, which leads to the **DESELECTED** state.
2. **Hover and Selection**:
- When the mouse hovers over the BBOX (**Mouse Over**), the state changes to **OVER**.
- From the **OVER** state, a left-click (**Left Click On BBOX**) changes the state to **SELECTED**.
- If the mouse moves out of the BBOX without selecting (**Mouse Out**), the state reverts to **DESELECTED**.
3. **Deselection**:
- From the **SELECTED** state, if a left-click is performed outside the BBOX (**Left Click Outside BBOX**), it transitions back to **DESELECTED**.
4. **Resizing**:
- While in the **SELECTED** state, dragging on the edges of the BBOX (**Drag on Left/Right/Top/Bottom Edge**) transitions to the **RESIZING** state.
- Within the **RESIZING** state, specific actions (resize from respective edges) are performed based on the edge dragged.
5. **Moving**:
- From the **SELECTED** state, dragging within the BBOX but not on the edge (**Drag Not on Edge**) transitions to the **MOVING** state.
- Within the **MOVING** state, dragging in specific directions (up, down, left, right) performs the corresponding move actions.
6. **Zooming**:
- At any point, using the mouse wheel transitions to the **ZOOMING** state.
- In the **ZOOMING** state, specific zoom actions are performed based on the wheel movement (zoom in or zoom out).
This diagram provides a comprehensive view of how mouse interactions transition between different states of a BBOX in a GUI, detailing the conditions and resulting actions for each transition.
This is remarkable and useful, specifically that it intuited:
- Drag Not on Edge: Condition for dragging not on the edge but within the BBOX. (this does not exist in the diagram. it made the intelligent and accurate conclusion.)
- RESIZE FROM LEFT EDGE, RIGHT EDGE, TOP EDGE, BOTTOM EDGE: Actions for resizing from respective edges. (the way it grouped cardinal directions intelligently to summarize and reinforce the meaning.)
- Super helpful is the way it articulated the flow state without me having to beg for it after the fact.
Either i'm an AI whisperer (not likely), my diagram was so good that it was simple to explain (also not really, because I get confused looking at it when I think about how to approach solving for it in code LOL!), or this AI stuff is no joke... 
So I figured I'd ask it to write the code too. Using QB64 3.13.1
---8<---
Continuing from the previous diagram session chat:
Could you please provide a QB64 program to implement this diagram fully? i would like to use this code in a modular way so please create it in a submodule, then also provide an example which uses the included submodule so I can test it. please do this using the latest QB64 Phoenix Edition version which is 3.13.1.
It's response:
GPT Wrote:Sure! Below is a QB64 program that implements the described state machine for BBOX mouse states. The program is divided into a submodule and a main program for testing. This implementation uses the QB64 Phoenix Edition version 3.13.1.
Submodule: bbox_mouse_states_module.bas
First, create a submodule named bbox_mouse_states_module.bas with the following code:
Code: (Select All)
SUB BBOXMouseStates
DIM SHARED mouseX, mouseY, mouseB, mouseOldB, state, dragging, dragStartX, dragStartY, bboxX, bboxY, bboxWidth, bboxHeight
CONST STATE_DESELECTED = 0
CONST STATE_OVER = 1
CONST STATE_SELECTED = 2
CONST STATE_MOVING = 3
CONST STATE_RESIZING = 4
CONST STATE_ZOOMING = 5
' Initialize the bounding box
bboxX = 200
bboxY = 150
bboxWidth = 200
bboxHeight = 150
' Initial state
state = STATE_DESELECTED
DO
_LIMIT 60
CLS
_MOUSEINPUT
mouseX = _MOUSEX
mouseY = _MOUSEY
mouseB = _MOUSEBUTTON(1)
SELECT CASE state
CASE STATE_DESELECTED
IF MouseOverBBox(mouseX, mouseY, bboxX, bboxY, bboxWidth, bboxHeight) THEN
state = STATE_OVER
END IF
CASE STATE_OVER
IF NOT MouseOverBBox(mouseX, mouseY, bboxX, bboxY, bboxWidth, bboxHeight) THEN
state = STATE_DESELECTED
ELSEIF mouseB THEN
state = STATE_SELECTED
END IF
CASE STATE_SELECTED
IF NOT mouseB AND NOT MouseOverBBox(mouseX, mouseY, bboxX, bboxY, bboxWidth, bboxHeight) THEN
state = STATE_DESELECTED
ELSEIF mouseB THEN
dragging = TRUE
dragStartX = mouseX
dragStartY = mouseY
IF MouseOnEdge(mouseX, mouseY, bboxX, bboxY, bboxWidth, bboxHeight) THEN
state = STATE_RESIZING
ELSE
state = STATE_MOVING
END IF
END IF
CASE STATE_MOVING
IF NOT mouseB THEN
state = STATE_SELECTED
dragging = FALSE
ELSE
bboxX = bboxX + (mouseX - dragStartX)
bboxY = bboxY + (mouseY - dragStartY)
dragStartX = mouseX
dragStartY = mouseY
END IF
CASE STATE_RESIZING
IF NOT mouseB THEN
state = STATE_SELECTED
dragging = FALSE
ELSE
' Handle resizing
IF mouseX < bboxX THEN bboxWidth = bboxWidth + (bboxX - mouseX): bboxX = mouseX
IF mouseX > bboxX + bboxWidth THEN bboxWidth = mouseX - bboxX
IF mouseY < bboxY THEN bboxHeight = bboxHeight + (bboxY - mouseY): bboxY = mouseY
IF mouseY > bboxY + bboxHeight THEN bboxHeight = mouseY - bboxY
END IF
END SELECT
' Draw the bounding box
LINE (bboxX, bboxY)-(bboxX + bboxWidth, bboxY + bboxHeight), _RGB32(255, 0, 0), B
' Display current state
SELECT CASE state
CASE STATE_DESELECTED: PRINT "State: DESELECTED"
CASE STATE_OVER: PRINT "State: OVER"
CASE STATE_SELECTED: PRINT "State: SELECTED"
CASE STATE_MOVING: PRINT "State: MOVING"
CASE STATE_RESIZING: PRINT "State: RESIZING"
CASE STATE_ZOOMING: PRINT "State: ZOOMING"
END SELECT
_DISPLAY
mouseOldB = mouseB
LOOP UNTIL INKEY$ = CHR$(27) ' Exit on ESC key
END SUB
FUNCTION MouseOverBBox (mx, my, bx, by, bw, bh)
IF mx >= bx AND mx <= bx + bw AND my >= by AND my <= by + bh THEN
MouseOverBBox = TRUE
ELSE
MouseOverBBox = FALSE
END IF
END FUNCTION
FUNCTION MouseOnEdge (mx, my, bx, by, bw, bh)
IF (mx >= bx AND mx <= bx + 5) OR (mx <= bx + bw AND mx >= bx + bw - 5) OR _
(my >= by AND my <= by + 5) OR (my <= by + bh AND my >= by + bh - 5) THEN
MouseOnEdge = TRUE
ELSE
MouseOnEdge = FALSE
END IF
END FUNCTION
Main Program: main.bas
Next, create the main program named main.bas with the following code to test the submodule:
Code: (Select All)
'$INCLUDE: 'bbox_mouse_states_module.bas'
SCREEN _NEWIMAGE(800, 600, 32)
_TITLE "BBOX Mouse States Demo"
BBOXMouseStates
Instructions to Compile and Run:
Create two files, bbox_mouse_states_module.bas and main.bas, and paste the respective codes into each file.
Open QB64 Phoenix Edition 3.13.1.
Load main.bas into QB64.
Ensure that both files are in the same directory or that the include path is correctly set.
Compile and run main.bas.
This program sets up a window with a bounding box that can be interacted with via mouse actions, implementing the state machine diagram you provided. You can resize, move, and observe state changes as described. Press the ESC key to exit the program.
While it didn't get that I need a input polling loop for mouse events in main, it got me pretty damned far.
I had to share this!
I FOR ONE WELCOME OUR NEW AI OVERLORDS.
The future is bright!
(i have not yet tested the code, I'm just grateful it could simplify my fucking state machine).
with peace and love,
grymmy
P.S.
Also, forgot this but don't want to interrupt the flow, here is a demo of img2ans working:
|
|
|
reading multiple mice from QB64PE, latest kludgey proof of concept, mostly works! |
|
Posted by: madscijr - 05-20-2024, 07:15 PM - Forum: Help Me!
- Replies (5)
|
 |
(Note: latest code is in replies below.)
A while back (discussed in this old thread) I tried getting QB64PE to read seperate input from >1 USB mice plugged into the computer.
With Spriggsy's help I got it working, sort of (see Program #1 below).
The problem was that it used some weird event code and therefore the regular QB64PE graphics and other commands don't seem to be available.
All that's available to draw on the screen are Windows API calls, which are hard to use and don't have anything to do with real QB64PE's nice commands.
So I made a proof of concept solution, which is have 2 programs running: - Program A reads the mice input using the API calls, and sends the data to Program B
- Program B gets the mice input from Program A, and just uses it as input in a regular QB64PE program.
(Thanks to Steve for explaining how to get one program to stay on top, which makes it possible to read the mouse from one program, but control the display from the other program.)
I'd be curious if anyone has any ideas for improving this or getting it to work more efficiently (ideally using just one program) and without throwing occasional weird errors.
Why??
Why would we want to use multiple mice on one PC? Good question!
(05-21-2024, 04:04 AM)grymmjack Wrote: @madscijr I have to ask. Why are you using 2 mice at once? LOL! My brain can barely handle 1 mouse at a time. This sounds fascinating and I'm really curious why you'd want to do this. Ha! OK this is going to sound ridiculous, but my initial motivation was simple:
I want to make 4-player or 8-player Pong games, that people can play on the same computer where everyone gets a mouse! 
Even a 2-player Pong game - why in the 40 years since PCs have had mouses, has no one ever done this?
How many Pong games have you seen where the players have to use a keyboard? What is this crap?? LOL
For paddle games to be playable you need a mouse!
It's long overdue! USB optical mice are cheap and plentiful.
Beyond that, multiple mice will be useful for games, or collaborative drawing, puzzles, etc.
Anything that needs a pointer or a spinner.
And racing games - it's super easy and cheap to turn an optical mouse into a racing wheel - all you need is a broom handle or wood dowel with a wheel at one end, and 6 or so inches of the other end stuck into a section of foam pool noodle. Then you just mount the mouse against that with duck tape or whatever, and voila! Instant racing wheel! It works great for games like Super Sprint in MAME, I've tried it. But to make multiplayer games like Indy 800, we need multiple mice! 
Taking the idea even further, did you know the Raw Input API can also do keyboards?
What about a split-screen multiplayer text adventure or coding game, where each player has their own keyboard and can fully type?
With the Raw Input API, we can do that!!
The sample programs
Program A: "readmice.bas" = multi-program kludge solution.
Run this and also run Program B (below).
Make sure 2 or more USB mice are plugged into the computer.
Position one window on top of the other.
This program continually reads multiple mice using the Windows RawInput API,
and sends the values to Program B (currently by writing the values to multiple files, 1 file per mouse).
Program B continually reads the latest mouse positions from the files,
and displays the values on the screen:
Code: (Select All) ' This version based on multimouse4.bas
' but changed to just write mouse values to a file
' madscijr - Mini-Mod
' #34
' 09-12-2022, 12:05 PM (This post was last modified: 09-12-2022, 12:07 PM by madscijr.)
' (09-09-2022, 04:27 PM) Spriggsy Wrote:
' >The button catching was working in the example I gave you so you might want to take a look at that mousemessage string. My version displayed the current button being pressed. Here is the relevant link for the RAWMOUSE struct.
' >https://docs.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-rawmouse
' >You can see the value for each button state listed there.
' >Edit.... Weird. Now it isn't wanting to work on my machine. It was working yesterday just fine.
' >Edit again.... Ah, I wasn't drawing the button information again. I accidentally erased the update. See below and you can try it out. The code does catch the buttons.
'
' Aha, thanks. The mouse button up/down are now being detected and I have it saving the state for left/middle/right clicks (code below).
'
' Now what black magic are we going to have to do, to get this out of the "event driven" code, and working like a regular QB64 program?
' ################################################################################################################################################################
' Multimouse
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' Plug in 2 or more USB mice and try moving them around
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' DONE:
' * detect mouse button clicks (left, middle, right buttons)
' Some issues and things to fix:
' * rework code from event-driven to linear (ie call a routine to get the
' latest coordinates / button states / scroll wheel for mouse n)
' * detect moving the scroll wheel
' * hide the real mouse cursor
' * get this working with _FullScreen _SquarePixels
' * scale the dx and dy of each mouse to 80x25 (or whatever target range is)
' * read the absolute position rather than dx and dy & fix scaling mouse
' coordinates to 80x25 (or whatever our target range is)
' * the code is seeing an extra (phantom) mouse - might be the disabled
' trackpad on my laptop. Is there a way to determine which mice or devices
' are disabled or can be ignored?
' * (later) Figure out how to do this for reading multiple keyboards.
' * (later) Figure out how to get the same functionality for Mac & Linux
' -------------------------------------------------------------------------------
' CHANGES
' -------------------------------------------------------------------------------
' DATE WHO WHAT
' 2004-04-22 jstookey added the ability to detect whether RawMouse is
' available or not so the application can either use a
' different multi-mouse system, or exit gracefully
' (thanks to Mark Healey).
' 2005-04-24 jstookey Modified the code work with the latest version of
' MinGW. The new MinGW incorporates rawinput, so my
' winuser header and library is obsolete.
' 2006-03-05 jstookey Initialized is_absolute and is_virtual_desktop to
' work better with newer versions of VStudio.
' 2022-09-07 madscijr Turned into a command line EXE that is called from
' QB64 with SpriggsySpriggs' pipecom from
' https://github.com/SpriggsySpriggs/Spriggsys-API-Collection/blob/master/Cross-Platform%20(Windows%2C%20Macintosh%2C%20Linux)/pipecomqb64.bas
' This version doesn't work.
' 2022-09-08 Spriggsy Converted C to pure QB64 code.
' 2022-09-09 madscijr Added demo code to move multiple objects on screen
' with separate mice independently.
' 2022-09-09 Spriggsy Added a screen refresh.
' 2022-09-10 madscijr Added detecting mouse buttons.
' 2024-05-19 madscijr Try having the program write mice coordinates / button states to a file that main program "always on top" without focus can read.
Option Explicit
_Title "readmice1"
$NoPrefix
$Console:Only
Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const FALSE = 0
Const TRUE = Not FALSE
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const IDI_APPLICATION = 32512
Const IDC_ARROW = 32512
Const COLOR_WINDOW = 5
Const WS_OVERLAPPED = &H00000000
Const WS_CAPTION = &H00C00000
Const WS_SYSMENU = &H00080000
Const WS_THICKFRAME = &H00040000
Const WS_MINIMIZEBOX = &H00020000
Const WS_MAXIMIZEBOX = &H00010000
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
Const CW_USEDEFAULT = &H80000000
Const WM_DESTROY = &H0002
Const WM_INPUT = &H00FF
Const SW_SHOW = 5
Const RID_INPUT = &H10000003
Const RIM_TYPEMOUSE = 0
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_NOCOALESCE = &H08
Const WM_MOUSEMOVE = &H0200
Const WM_PAINT = &H000F
Const DT_CENTER = &H00000001
' MIN/MAX VALUES FOR MOUSE TEST
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
const cFileName = 0
const cFileData = 1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget
End Type
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
Type POINT
As Long x, y
End Type
Type MSG
As Offset hwnd
As Unsigned Long message
As Unsigned Offset wParam
As Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
Type WNDCLASSEX
As Unsigned Long cbSize, style
As Offset lpfnWndProc
As Long cbClsExtra, cbWndExtra
As Offset hInstance, hIcon, hCursor, hbrBackground, lpszMenuName, lpszClassName, hIconSm
End Type
Type RECT
As Long left, top, right, bottom
End Type
Type PAINTSTRUCT
As Offset hdc
As Long fErase
$If 64BIT Then
As String * 4 alignment
$End If
As RECT rcPaint
As Long fRestore, fIncUpdate
As String * 32 rgbReserved
End Type
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
Type RAWMOUSE
As Unsigned Integer usFlags
$If 64BIT Then
As String * 2 alignment
$End If
'As Unsigned Long ulButtons 'commented out because I'm creating this value using MAKELONG
As Unsigned Integer usButtonFlags, usButtonData
As Unsigned Long ulRawButtons
As Long lLastX, lLastY
As Unsigned Long ulExtraInformation
End Type
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
End Type
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type InfoType
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
wheel As Integer ' mouse wheel value
LeftDown As Integer ' tracks left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' InfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Declare CustomType Library
Function GetRawInputDeviceList~& (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Sub GetRawInputDeviceList (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Function RegisterRawInputDevices& (ByVal pRawInputDevices As Offset, Byval uiNumDevices As Unsigned Long, Byval cbSize As Unsigned Long)
Function GetModuleHandle%& (ByVal lpModulename As Offset)
Function LoadIcon%& (ByVal hInstance As Offset, Byval lpIconName As Offset)
Function LoadCursor%& (ByVal hInstance As Offset, Byval lpCursorName As Offset)
Function RegisterClassEx~% (ByVal wndclassex As Offset)
Function CreateWindowEx%& (ByVal dwExStyle As Unsigned Long, Byval lpClassName As Offset, Byval lpWindowName As Offset, Byval dwStyle As Unsigned Long, Byval x As Long, Byval y As Long, Byval nWidth As Long, Byval nHeight As Long, Byval hWndParent As Offset, Byval hMenu As Offset, Byval hInstance As Offset, Byval lpParam As Offset)
Sub ShowWindow (ByVal hWnd As Offset, Byval nCmdShow As Long)
Sub UpdateWindow (ByVal hWnd As Offset)
Function GetMessage& (ByVal lpMsg As Offset, Byval hWnd As Offset, Byval wMsgFilterMin As Unsigned Long, Byval wMsgFilterMax As Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As Offset)
Sub DispatchMessage (ByVal lpMsg As Offset)
Sub PostQuitMessage (ByVal nExitCode As Long)
Function DefWindowProc%& (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Sub GetRawInputData (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Function GetRawInputData~& (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Sub InvalidateRect (ByVal hWnd As Offset, Byval lpRect As Offset, Byval bErase As Long)
Sub SendMessage (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Function BeginPaint%& (ByVal hWnd As Offset, Byval lpPaint As Offset)
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned Long)
Sub OffsetRect (ByVal lprc As Offset, Byval dx As Long, Byval dy As Long)
Sub EndPaint (ByVal hWnd As Offset, Byval lpPaint As Offset)
End Declare
' Header file "makeint.h" must be in same folder as this program.
Declare CustomType Library ".\makeint"
Function MAKEINTRESOURCE%& Alias "MAKEINTRSC" (ByVal i As _Offset)
End Declare
Declare Library
Function MAKELPARAM%& (ByVal l As Integer, Byval h As Integer)
Function MAKELONG~& (ByVal l As Unsigned Integer, Byval h As Unsigned Integer)
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\windowsx"
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\windowsx"
$End If
Function GET_Y_LPARAM& (ByVal lp As Offset)
Function GET_X_LPARAM& (ByVal lp As Offset)
End Declare
' Header file "winproc.h" must be in same folder as this program.
Declare Library ".\winproc"
Function WindowProc%& ()
End Declare
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE TEST VARIABLES
Dim Shared arrInfo(8) As InfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' RAW FILE NAMES
Dim Shared arrFile(0 To 31, 0 To 1) As String
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' $Console
' _Delay 4
' _Console On
' _Echo "Started " + m_ProgramName$
' _Echo "Debugging on..."
'End If
' ****************************************************************************************************************************************************************
' END ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' INITIALIZE GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim iLoop As Integer
For iLoop = lbound(arrFile) to ubound(arrFile)
arrFile(iLoop, cFileName) = m_ProgramPath$ + "mouse" + _Trim$(Str$(iLoop)) + ".txt"
arrFile(iLoop, cFileData) = ""
Next iLoop
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0 ' <<< NOT WORKING, HOW DO WE DO THIS IN THE EVENT MODEL?
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
System Val(Str$(WinMain))
' ****************************************************************************************************************************************************************
' BEGIN DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' _Console Off
'End If
' ****************************************************************************************************************************************************************
' END DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE CURSORS (JUST SOME LETTERS)
CData:
Data A,b,C,D,E,f,G,H
' DEFAULT/INTIAL X COORDINATE OF EACH CURSOR ON SCREEN
XData:
Data 5,15,25,35,45,55,65,75
' DEFAULT/INTIAL Y COORDINATE OF EACH CURSOR ON SCREEN
YData:
Data 17,17,19,19,21,21,23,23
' DEFAULT/INITIAL VALUE OF EACH SCROLL WHEEL
WData:
Data 224,192,160,128,96,64,32,0
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
Dim As Offset hwndMain, hInst
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
'DEBUG: SUBSTITUTE _WindowHandle
hwndMain = CreateWindowEx(0, MAKELPARAM(reg, 0), Offset(szWinTitle), WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, hInst, 0)
'hwndMain = _WindowHandle
'DEBUG: SUBSTITUTE _WindowHandle
ShowWindow hwndMain, SW_SHOW
'ShowWindow _WindowHandle, SW_SHOW
'DEBUG: SUBSTITUTE _WindowHandle
UpdateWindow hwndMain
'UpdateWindow _WindowHandle
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT raw
Dim As Long tmpx, tmpy
Static As Long maxx
Dim As RAWINPUTHEADER rih
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
Dim strNextID As String
Dim iIndex As Integer
Dim iRowOffset As Integer
Dim iLen As Integer
Dim sCount As String
Dim sX As String
Dim sY As String
Dim sWheel As String
Dim sLeftDown As String
Dim sMiddleDown As String
Dim sRightDown As String
Dim sLeftCount As String
Dim sMiddleCount As String
Dim sRightCount As String
Dim sNext As String
Dim iNewX As Integer
Dim iNewY As Integer
Dim iDX As Integer
Dim iDY As Integer
' MORE TEMP VARIABLES
dim iMouseNum as integer
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
'Print "GetRawInputData doesn't return correct size!"
mousemessage = "GetRawInputData doesn't return correct size!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
' GET MOUSE INFO
' NOTES:
' ulButtons and usButtonFlags both return the same thing (buttons)
' usButtonData changes value when scroll wheel moved (just stays at one value)
'mousemessage = ""
'mousemessage = mousemessage + "Mouse:hDevice" + Str$(raw.header.hDevice)
'mousemessage = mousemessage + "usFlags=" + Hex$(raw.mouse.usFlags)
'mousemessage = mousemessage + "ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
'mousemessage = mousemessage + "usButtonFlags=" + Hex$(raw.mouse.usButtonFlags)
'mousemessage = mousemessage + "usButtonData=" + Hex$(raw.mouse.usButtonData)
'mousemessage = mousemessage + "ulRawButtons=" + Hex$(raw.mouse.ulRawButtons)
'mousemessage = mousemessage + "lLastX=" + Str$(raw.mouse.lLastX)
'mousemessage = mousemessage + "lLastY=" + Str$(raw.mouse.lLastY)
'mousemessage = mousemessage + "ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
' UPDATE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x - 1
ElseIf raw.mouse.lLastX > 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x + 1
End If
If raw.mouse.lLastY < 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y - 1
ElseIf raw.mouse.lLastY > 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y + 1
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'Hex$(raw.mouse.usButtonFlags)
' left button = 1 when down, 2 when released
If ((raw.mouse.usButtonFlags And 1) = 1) Then
arrInfo(iIndex).LeftDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 2) = 2) Then
arrInfo(iIndex).LeftDown = FALSE
End If
' middle button = 16 when down, 32 when released
If ((raw.mouse.usButtonFlags And 16) = 16) Then
arrInfo(iIndex).MiddleDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 32) = 32) Then
arrInfo(iIndex).MiddleDown = FALSE
End If
' right button = 4 when down, 8 when released
If ((raw.mouse.usButtonFlags And 4) = 4) Then
arrInfo(iIndex).RightDown = TRUE
ElseIf ((raw.mouse.usButtonFlags And 8) = 8) Then
arrInfo(iIndex).RightDown = FALSE
End If
' scroll wheel = ???
'arrInfo(iIndex).wheel = ???
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' CHECK BOUNDARIES
If arrInfo(iIndex).x < cMinX Then arrInfo(iIndex).x = cMinX
If arrInfo(iIndex).x > cMaxX Then arrInfo(iIndex).x = cMaxX
If arrInfo(iIndex).y < cMinY Then arrInfo(iIndex).y = cMinY
If arrInfo(iIndex).y > cMaxY Then arrInfo(iIndex).y = cMaxY
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
' WRITE VALUES FOR THIS MOUSE TO FILE
arrFile(iIndex, cFileData) = ""
arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).x))) + Chr$(13)
arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).y))) + Chr$(13)
arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).wheel))) + Chr$(13)
arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftDown))) + Chr$(13)
arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleDown))) + Chr$(13)
arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).RightDown))) + Chr$(13)
'arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftCount))) + Chr$(13)
'arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleCount))) + Chr$(13)
'arrFile(iIndex, cFileData) = arrFile(iIndex, cFileData) + LTrim$(RTrim$(Str$(arrInfo(iIndex).RightCount))) + Chr$(13)
OPEN arrFile(iIndex, cFileName) FOR OUTPUT AS #1
PRINT #1, arrFile(iIndex, cFileData)
CLOSE #1
' ----------------------------------------------------------------------------------------------------------------------------------------------------------------
End If
End If
' ================================================================================================================================================================
' BEGIN WRITE OUTPUT FILE
' ================================================================================================================================================================
'ClearText
'WriteText 1, 1, "1. PLUG 1-8 MICE INTO THE COMPUTER"
'WriteText 2, 1, "2. USE MICE TO POSITION LETTERS ON SCREEN"
'WriteText 3, 1, "3. PRESS <ESC> TO QUIT"
'WriteText 4, 1, "--------------------------------------------------------------------------------"
'WriteText 5, 1, "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
'WriteText 6, 1, "--------------------------------------------------------------------------------"
'' NOTE: LEAVE THE NEXT 8 LINES FREE (ROWS 8-15)
'' TO DISPLAY TEST VALUES FOR UPTO 8 MICE
'
'' DRAW BORDER AROUND PLAYING FIELD
'DrawTextLine cMinX - 1, cMinY - 1, cMinX - 1, cMaxY + 1, "#"
'DrawTextLine cMinX - 1, cMinY - 1, cMaxX + 1, cMinY - 1, "#"
'DrawTextLine cMaxX + 1, cMaxY + 1, cMaxX + 1, cMinY - 1, "#"
'DrawTextLine cMaxX + 1, cMaxY + 1, cMinX - 1, cMaxY + 1, "#"
'' GET INPUT AND MOVE PLAYERS
'iRowOffset = 0
'iMouseNum = 0
'For iIndex = LBound(arrInfo) To UBound(arrInfo)
' iMouseNum = iMouseNum + 1
'
' ' CHECK BOUNDARIES
' If arrInfo(iIndex).x < cMinX Then arrInfo(iIndex).x = cMinX
' If arrInfo(iIndex).x > cMaxX Then arrInfo(iIndex).x = cMaxX
' If arrInfo(iIndex).y < cMinY Then arrInfo(iIndex).y = cMinY
' If arrInfo(iIndex).y > cMaxY Then arrInfo(iIndex).y = cMaxY
'
' ' PLOT CURSOR
' WriteText arrInfo(iIndex).y, arrInfo(iIndex).x, arrInfo(iIndex).c
'
' ' DISPLAY VARIABLES
' iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iRowOffset + 1))) + String$(iLen, " "), iLen)
' iLen = 3: sX = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).x))) + String$(iLen, " "), iLen)
' iLen = 3: sY = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).y))) + String$(iLen, " "), iLen)
' iLen = 6: sWheel = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).wheel))) + String$(iLen, " "), iLen)
' iLen = 9: sLeftDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftDown))) + String$(iLen, " "), iLen)
' iLen = 11: sMiddleDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleDown))) + String$(iLen, " "), iLen)
' iLen = 10: sRightDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightDown))) + String$(iLen, " "), iLen)
' iLen = 10: sLeftCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftCount))) + String$(iLen, " "), iLen)
' iLen = 12: sMiddleCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleCount))) + String$(iLen, " "), iLen)
' iLen = 11: sRightCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightCount))) + String$(iLen, " "), iLen)
' 'sNext = sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
' WriteText 6 + iRowOffset, 1, sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
' iRowOffset = iRowOffset + 1
'Next iIndex
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END WRITE OUTPUT FILE
' ================================================================================================================================================================
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
End If
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE
'mousemessage = mousemessage + "X:" + Str$(GET_X_LPARAM(lParam))
'mousemessage = mousemessage + " Y:" + Str$(GET_Y_LPARAM(lParam))
'mousemessage = mousemessage + Chr$(0)
' SAVE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
''iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ 1520
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
''iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ 782
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
' (should we update here too?)
'TODO: SAVE SCROLL WHEEL + BUTTONS
' (should we update here too?)
'arrInfo(iIndex).wheel =
'arrInfo(iIndex).LeftDown =
'arrInfo(iIndex).MiddleDown =
'arrInfo(iIndex).RightDown =
End If
End If
'DEBUG: SUBSTITUTE _WindowHandle
InvalidateRect hwnd, 0, -1
'InvalidateRect _WindowHandle, 0, -1
'DEBUG: SUBSTITUTE _WindowHandle
SendMessage hwnd, WM_PAINT, 0, 0
'SendMessage _WindowHandle, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_PAINT
'DEBUG: SUBSTITUTE _WindowHandle
hdc = BeginPaint(hwnd, Offset(ps))
'hdc = BeginPaint(_WindowHandle, Offset(ps))
'DEBUG: SUBSTITUTE _WindowHandle
GetClientRect hwnd, Offset(rc)
'GetClientRect _WindowHandle, Offset(rc)
DrawText hdc, Offset(mousemessage), Len(mousemessage), Offset(rc), DT_CENTER
OffsetRect Offset(rc), 0, 200
'' PRINT LIST OF RawInput DEVICES:
'DrawText hdc, Offset(rawinputdevices), Len(rawinputdevices), Offset(rc), DT_CENTER
'DEBUG: SUBSTITUTE _WindowHandle
EndPaint hwnd, Offset(ps)
'EndPaint _WindowHandle, Offset(ps)
MainWndProc = 0
Exit Function
Case Else
'DEBUG: SUBSTITUTE _WindowHandle
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
'MainWndProc = DefWindowProc(_WindowHandle, nMsg, wParam, lParam)
End Select
if _KeyDown(27) then end
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
pRawInputDeviceList = MemNew(Len(RawInputDeviceList) * nDevices)
GetRawInputDeviceList pRawInputDeviceList.OFFSET, Offset(nDevices), Len(RawInputDeviceList)
' This small block of commented code proves that we've got the device list
ReDim As RAWINPUTDEVICELIST rawdevs(0 To nDevices - 1)
MemGet pRawInputDeviceList, pRawInputDeviceList.OFFSET, rawdevs()
' GET MOUSE INFO
iMouseCount = 0
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
For x = 0 To UBound(rawdevs)
rawinputdevices = rawinputdevices + Str$(rawdevs(x).hDevice) + ":" + Str$(rawdevs(x).dwType) + Chr$(13)
' Is it a mouse?
'TODO: SAVE_MOUSE_INFO
If rawdevs(x).dwType = 0 Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrInfo(iMouseCount-1).ID = lngNextID
arrInfo(iMouseCount - 1).ID = strNextID
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
'DEBUG: SUBSTITUTE _WindowHandle
Rid(0).hwndTarget = 0
'Rid(0).hwndTarget = _WindowHandle
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
mousemessage = "RawInput init failed" + Chr$(0)
End If
End Sub ' InitRawInput
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Initialize mouse test stuff
'TODO: SAVE_MOUSE_INFO
Sub InitMouseTest
Dim iIndex As Integer
Dim iLoop As Integer
' FOR NOW ONLY SUPPORT UPTO 8 MICE
If (iMouseCount > 8) Then iMouseCount = 8
' INITIALIZE CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).c
' INITIALIZED BELOW: arrInfo(iIndex).x = 0
' INITIALIZED BELOW: arrInfo(iIndex).y = 0
' INITIALIZED BELOW: arrInfo(iIndex).wheel = 127
arrInfo(iIndex).LeftDown = FALSE
arrInfo(iIndex).MiddleDown = FALSE
arrInfo(iIndex).RightDown = FALSE
arrInfo(iIndex).LeftCount = 0
arrInfo(iIndex).MiddleCount = 0
arrInfo(iIndex).RightCount = 0
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrInfo where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrInfo) - 1
For iLoop = LBound(arrInfo) To UBound(arrInfo)
If arrInfo(iLoop).ID = MouseID Then
iIndex% = iLoop
Exit For
Else
' not it
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
Dim iColNum As Integer
Dim iRowNum As Integer
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
arrScreen(iColNum, iRowNum) = " "
Next iRowNum
Next iColNum
End Sub ' ClearText
' /////////////////////////////////////////////////////////////////////////////
' Plots string MyString to position (iX, iY) in global array arrScreen.
Sub WriteText (iRow As Integer, iColumn As Integer, MyString As String)
Dim iPos As Integer
Dim iLoop As Integer
If iColumn > 0 And iColumn < 81 Then
If iRow > 0 And iRow < 26 Then
For iLoop = 1 To Len(MyString)
iPos = iColumn + (iLoop - 1)
If iPos < 81 Then
arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
Else
Exit For
End If
Next iLoop
End If
End If
End Sub ' WriteText
' /////////////////////////////////////////////////////////////////////////////
' Converts global array arrScreen to a string.
Function ScreenToString$
Dim sResult As String
Dim iColNum As Integer
Dim iRowNum As Integer
sResult = ""
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
sResult = sResult + arrScreen(iColNum, iRowNum)
Next iColNum
sResult = sResult + Chr$(13)
Next iRowNum
ScreenToString$ = sResult
End Function ' ScreenToString$
' /////////////////////////////////////////////////////////////////////////////
' based on code from:
' Qbasic Programs - Download free bas source code
' http://www.thedubber.altervista.org/qbsrc.htm
Sub DrawTextLine (y%, x%, y2%, x2%, c$)
Dim i%
Dim steep%
Dim e%
Dim sx%
Dim dx%
Dim sy%
Dim dy%
i% = 0: steep% = 0: e% = 0
If (x2% - x%) > 0 Then sx% = 1: Else sx% = -1
dx% = Abs(x2% - x%)
If (y2% - y%) > 0 Then sy% = 1: Else sy% = -1
dy% = Abs(y2% - y%)
If (dy% > dx%) Then
steep% = 1
Swap x%, y%
Swap dx%, dy%
Swap sx%, sy%
End If
e% = 2 * dy% - dx%
For i% = 0 To dx% - 1
If steep% = 1 Then
''PSET (y%, x%), c%:
'Locate y%, x% : Print c$;
WriteText y%, x%, c$
Else
''PSET (x%, y%), c%
'Locate x%, y% : Print c$;
WriteText x%, y%, c$
End If
While e% >= 0
y% = y% + sy%: e% = e% - 2 * dx%
Wend
x% = x% + sx%: e% = e% + 2 * dy%
Next
''PSET (x2%, y2%), c%
'Locate x2%, y2% : Print c$;
WriteText x2%, y2%, c$
End Sub ' DrawTextLine
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of RawInput mouse devices connected to the system
' *****************************************************************************
' TODO: GET COUNT FROM RawInput API
' For now, hardcoded to 1 until we figure out how to do this.
' *****************************************************************************
Function GetRawMouseCount% ()
GetRawMouseCount% = 1
End Function ' GetRawMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each RawInput mouse device connected to the system (for now upto 8)
' Returns the IDs in an array of LONG <- may change depending on whether
' we save each the device handle for each mouse or the index
' If no mouse found, the ID will just be 0 <- or whatever value we decide as default/none
' *****************************************************************************
' TODO: GET THIS FROM RawInput API
' For now, hardcoded arrRawMouseID(1) to 1, and the rest 0, until we figure out how to do this.
' *****************************************************************************
'Sub GetRawMouseIDs (arrRawMouseID( 8) As Integer)
Sub GetRawMouseIDs ()
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
''arrRawMouseID(iLoop) = 0
'arrInfo(iLoop).ID = 0
arrInfo(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrInfo(0).ID = 1 ' for now just fudge it!
End Sub ' GetRawMouseIDs
' /////////////////////////////////////////////////////////////////////////////
' Read mouse using RawInput API
' Gets input from mouse, MouseID% = which mouse
' NOTE: click events (mouse up/mouse down) are handled by the calling sub,
' this routine just sends back
' TRUE if the given button is currently down or FALSE if it is up.
' Parameters (input only):
' MouseID% = which mouse to return input for
' wheelMin% = minimum value to allow wheelValue% to be decremented to
' wheelMax% = maximum value to allow wheelValue% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' leftButton% = current state of left mouse button (up or down)
' middleButton% = current state of middle mouse button / scroll wheel button (up or down)
' rightButton% = current state of right mouse button (up or down)
' wheelValue% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, leftButton%, middleButton%, rightButton%, wheelValue%, wheelMin%, wheelMax%)
Dim scrollAmount%
Dim dx%
Dim dy%
' =============================================================================
' BEGIN READ MOUSE THE NEW RawInput WAY:
' read scroll wheel
'TODO: get this from RawInput API
' determine mouse x position
'TODO: get this from RawInput API
dx% = 0 ' = getMouseDx(MouseID%)
x% = x% + dx% ' adjust mouse value by dx
' determine mouse y position
'TODO: get this from RawInput API
dy% = 0 ' = getMouseDy(MouseID%)
y% = y% + dy% ' adjust mouse value by dx
' read mouse buttons
'TODO: get this from RawInput API
leftButton% = FALSE
middleButton% = FALSE
rightButton% = FALSE
' END READ MOUSE THE NEW RawInput WAY:
' =============================================================================
' =============================================================================
' BEGIN READ MOUSE THE OLD QB64 WAY:
'
'' read scroll wheel
'WHILE _MOUSEINPUT ' get latest mouse information
' scrollAmount% = _MOUSEWHEEL ' (Returns -1 when scrolling up and 1 when scrolling down with 0 indicating no movement since last read.)
' IF (scrollAmount% = -1) AND (wheelValue% > wheelMin%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheelValue% < wheelMax%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _MOUSEY
'
'' read mouse buttons
'leftButton% = _MOUSEBUTTON(1)
'middleButton% = _MOUSEBUTTON(3)
'rightButton% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' FOR BITWISE OPERATIONS
Function HasBit% (iByte As Integer, iBit As Integer)
''TODO: precalculate
'dim shared m_arrBitValue(1 To 8) As Integer
'dim iLoop as Integer
'For iLoop = 0 To 7
' m_arrBitValue(iLoop + 1) = 2 ^ iLoop
'Next iLoop
'HasBit% = ((iByte And m_arrBitValue(iBit)) = m_arrBitValue(iBit))
Dim iBitValue As Integer
iBitValue = 2 ^ (iBit - 1)
HasBit% = ((iByte And iBitValue) = iBitValue)
End Function ' HasBit%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPrint (MyString As String)
' If m_bDebug = TRUE Then
' '_Echo MyString
' ReDim arrLines(-1) As String
' Dim iLoop As Integer
' split MyString, Chr$(13), arrLines()
' For iLoop = LBound(arrLines) To UBound(arrLines)
' _Echo arrLines(iLoop)
' Next iLoop
' End If
'End Sub ' DebugPrint
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' @END
Program B: "mainprog.bas"
The 2nd part of multi-program kludge solution.
Plug 2 USB mice into your computer.
Run this and also run Program A (above).
Position one windows on top of the other
(or else maximize Program A and make sure it has the focus).
Give Program A the focus, position the mouse pointer over the window, and move both or all mice.
You should see them independently controlling stuff on the screen, and the values change for all.
Program A reads multiple mice, and saves the values to multiple files (1 file per mouse),
while Program B continually reads the latest mouse positions from the files,
and displays the values on the screen.
Currently it's hardcoded to just read 2 mice (line 99). To get more mice, comment out line 99 and uncomment line 98 above it.
NOTE: It sometimes give a file error, click Yes to continue and click on Program A to give it back the focus and it will continue working.
I'm Not sure why it's giving the errors, or how to revert focus back to program A when user clicks the mouse buttons (clicking the mouse button shifts focus to program B).
There has to be a better / more efficient way to get program A to send its data to program B instead of writing/reading files, maybe some shared environmental values in memory, or local network communication?
Better yet, how can all the code be made to work in just one program?
Code: (Select All) ' McNeill - Super Moderator
' #2
' 05-17-2024, 07:27 PM (This post was last modified: 05-17-2024, 07:28 PM by SMcNeill.)
' https://qb64phoenix.com/qb64wiki/index.php/Windows_Libraries#Top_Most_Window
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const cProgName = "mainprog"
Const FALSE = 0
Const TRUE = Not FALSE
' TEXT MODE COLORS:
Const cBlack = 0: Const cBlue = 1: Const cGreen = 2: Const cLtBlue = 3
Const cRed = 4: Const cPurple = 5: Const cOrange = 6: Const cWhite = 7
Const cGray = 8: Const cPeriwinkle = 9: Const cLtGreen = 10: Const cCyan = 11
Const cLtRed = 12: Const cPink = 13: Const cYellow = 14: Const cLtGray = 15
Const SWP_NOSIZE = &H0001 'ignores cx and cy size parameters
Const SWP_NOMOVE = &H0002 'ignores x and y position parameters
Const SWP_NOZORDER = &H0004 'keeps z order and ignores hWndInsertAfter parameter
Const SWP_NOREDRAW = &H0008 'does not redraw window changes
Const SWP_NOACTIVATE = &H0010 'does not activate window
Const SWP_FRAMECHANGED = &H0020
Const SWP_SHOWWINDOW = &H0040
Const SWP_HIDEWINDOW = &H0080
Const SWP_NOCOPYBITS = &H0100
Const SWP_NOOWNERZORDER = &H0200
Const SWP_NOSENDCHANGING = &H0400
Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Const SWP_DEFERERASE = &H2000
Const SWP_ASYNCWINDOWPOS = &H4000
Const HWND_TOP = 0 'window at top of z order no focus
Const HWND_BOTTOM = 1 'window at bottom of z order no focus
Const HWND_TOPMOST = -1 'window above all others no focus unless active
Const HWND_NOTOPMOST = -2 'window below active no focus
' CONSTANT FOR 2ND DIMENSION OF arrFile ARRAY
Const cFileName = 0
Const cFileData = 1
' CONSTANT FOR WHAT DATA IS EXPECTED FROM THIS LINE IN FILE
Const cMouseX = 1
Const cMouseY = 2
Const cMouseWheel = 3
Const cMouseLeftDown = 4
Const cMouseMiddleDown = 5
Const cMouseRightDown = 6
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Declare Dynamic Library "user32"
Function FindWindowA%& (ByVal lpClassName%&, Byval lpWindowName%&)
Function SetWindowPos& (ByVal hWnd%&, Byval hWndInsertAfter%&, Byval X&, Byval Y&, Byval cx&, Byval cy&, Byval uFlags~&)
Function GetForegroundWindow%&
End Declare
Declare Dynamic Library "kernel32"
Function GetLastError~& ()
End Declare
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type InfoType
ID As String ' player identifier or mouse device ID
char As String ' cursor character
color As Integer ' character color
row As Integer ' line to display values at
x As Integer ' screen x position
y As Integer ' screen y position
oldX As Integer
oldY As Integer
wheel As Integer ' mouse wheel value
LeftDown As Integer ' tracks left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' InfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' MOUSE TEST VARIABLES
'Dim Shared arrInfo(8) As InfoType ' STORES INFO FOR EACH MOUSE
Dim Shared arrInfo(0 To 1) As InfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' RAW FILE NAMES
Dim Shared arrFile(0 To 31, 0 To 1) As String
' WINDOW VARIABLES
Dim Shared hWndThis As _Offset ' hWndThis%&
Dim Shared hWndTop As _Offset ' x%&
' OTHER VARS
Dim Shared iLoop As Integer
Dim Shared sError As String
Dim Shared iIndex As Integer
Dim Shared sLine As String
Dim Shared iLineNum As Integer
Dim Shared iCount As Integer
Dim Shared iCol As Integer
Dim Shared iRow As Integer
Dim Shared arrColor(0 To 31) As Integer
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' INITIALIZE GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
sError = ""
' INITIALIZE MOUSE INPUT FILENAMES
For iLoop = LBound(arrFile) To UBound(arrFile)
arrFile(iLoop, cFileName) = m_ProgramPath$ + "mouse" + _Trim$(Str$(iLoop)) + ".txt"
arrFile(iLoop, cFileData) = ""
Next iLoop
' INITALIZE COLORS
iCount = 0
For iLoop = LBound(arrColor) To UBound(arrColor)
iCount = iCount + 1: If iCount > 15 Then iCount = 1
arrColor(iLoop) = iCount
Next iLoop
' INITIALIZE USER DATA
iCount = 0
For iIndex = LBound(arrInfo) To UBound(arrInfo)
iCount = iCount + 1
arrInfo(iIndex).ID = "Mouse" + _Trim$(Str$(iCount))
arrInfo(iIndex).char = Chr$(64 + iCount)
arrInfo(iIndex).color = arrColor(iCount)
arrInfo(iIndex).row = iCount + 3
arrInfo(iIndex).x = 1
arrInfo(iIndex).y = 1
arrInfo(iIndex).oldX = 1
arrInfo(iIndex).oldY = 1
arrInfo(iIndex).wheel = 0
arrInfo(iIndex).LeftDown = FALSE
arrInfo(iIndex).MiddleDown = FALSE
arrInfo(iIndex).RightDown = FALSE
arrInfo(iIndex).LeftCount = 0
arrInfo(iIndex).MiddleCount = 0
arrInfo(iIndex).RightCount = 0
Next iIndex
Const cBlack = 0: Const cBlue = 1: Const cGreen = 2: Const cLtBlue = 3
Const cRed = 4: Const cPurple = 5: Const cOrange = 6: Const cWhite = 7
Const cGray = 8: Const cPeriwinkle = 9: Const cLtGreen = 10: Const cCyan = 11
Const cLtRed = 12: Const cPink = 13: Const cYellow = 14: Const cLtGray = 15
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOVE WINDOW TO TOP
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' GET WINDOW HANDLES
hWndThis = _WindowHandle ' FindWindowA(0, _OFFSET(t))
hWndTop = GetForegroundWindow%& ' find currently focused process handle
' GET FOCUS
If hWndThis <> hWndTop Then
_ScreenClick 240, 240 ' add 40 to x and y to focus on positioned window
End If
' MOVE TO TOP
If SetWindowPos(hWndThis, HWND_TOPMOST, 200, 200, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE) = 0 Then
sError = "SetWindowPos failed. 0x" + LCase$(Hex$(GetLastError))
End If
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MAIN EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
_Title cProgName
Screen 12 ' SCREEN 12 can use 16 color attributes with a black background. 256K possible RGB color hues. Background colors can be used with QB64.
' window needs to be lined up directly under the main program, so the mouse coordinates align with the display
_ScreenMove 0, 0
Cls , cBlack
' MAIN LOOP
Do
' PRINT HEADER ROW
iRow = 3: iCol = 1
Color cBlack, cWhite
Locate iRow, iCol: Print "ID ": iCol = iCol + 9
Locate iRow, iCol: Print "CHAR ": iCol = iCol + 9
Locate iRow, iCol: Print "X ": iCol = iCol + 9
Locate iRow, iCol: Print "Y ": iCol = iCol + 9
Locate iRow, iCol: Print "WHEEL ": iCol = iCol + 9
Locate iRow, iCol: Print "LEFT ": iCol = iCol + 9
Locate iRow, iCol: Print "MIDDLE ": iCol = iCol + 9
Locate iRow, iCol: Print "RIGHT ": iCol = iCol + 9
' PROCESS EACH USER'S INPUT
For iIndex = LBound(arrInfo) To UBound(arrInfo)
' READ MICE COORDINATES FROM FILE...
' DISPLAY VALUES TO NEXT ROW
iRow = arrInfo(iIndex).row: iCol = 1
Color arrInfo(iIndex).color, cBlack
Locate iRow, iCol: Print arrInfo(iIndex).ID + " ": iCol = iCol + 9
Locate iRow, iCol: Print arrInfo(iIndex).char + " ": iCol = iCol + 9
' REDRAW AND SAVE OLD COORDINATES
If arrInfo(iIndex).oldX <> arrInfo(iIndex).x Or arrInfo(iIndex).oldY <> arrInfo(iIndex).y Then
Locate arrInfo(iIndex).oldY, arrInfo(iIndex).oldX: Print " "
Locate arrInfo(iIndex).y, arrInfo(iIndex).x: Print arrInfo(iIndex).char
arrInfo(iIndex).oldY = arrInfo(iIndex).y
arrInfo(iIndex).oldX = arrInfo(iIndex).x
End If
' FOUND FILE?
If _FileExists(arrFile(iIndex, cFileName)) = TRUE Then
' OPEN FILE
Open arrFile(iIndex, cFileName) For Input As #1
'' DEBUG OUTPUT:
'Print "File: " + chr$(34) + arrFile(iIndex, cFileName) + chr$(34)
' READ EACH LINE
iLineNum = 0
While Not EOF(1)
' TRACK WHAT LINE # WE'RE ON
iLineNum = iLineNum + 1
' READ LINE
Line Input #1, sLine ' read entire text file line
'INPUT #1, sChar ' read a character?
'' DEBUG OUTPUT:
'print "Line #" + _Trim$(Str$(iLineNum)) + " = " + chr$(34) + sLine + chr$(34)
' IS IT A VALID INTEGER?
If IsNumber%(sLine) Then
' DETERMINE WHICH VALUE IT IS FROM ORDINAL POSITION (LINE #) IN FILE
' AND SAVE TO APPROPRIATE VARIABLE
Select Case iLineNum
Case cMouseX:
'arrInfo(iIndex).x = Val(sLine)
'Locate iRow, iCol: Print _Trim$(Str$(arrInfo(iIndex).x)) + " ": iCol = iCol + 9
Locate iRow, iCol: Print sLine + " ": iCol = iCol + 9
arrInfo(iIndex).x = Val(sLine)
Case cMouseY:
'arrInfo(iIndex).y = Val(sLine)
'Locate iRow, iCol: Print _Trim$(Str$(arrInfo(iIndex).y)) + " ": iCol = iCol + 9
Locate iRow, iCol: Print sLine + " ": iCol = iCol + 9
arrInfo(iIndex).y = Val(sLine)
Case cMouseWheel:
'arrInfo(iIndex).wheel = Val(sLine)
'Locate iRow, iCol: Print _Trim$(Str$(arrInfo(iIndex).wheel)) + " ": iCol = iCol + 9
Locate iRow, iCol: Print sLine + " ": iCol = iCol + 9
Case cMouseLeftDown:
'arrInfo(iIndex).LeftDown = Val(sLine)
'Locate iRow, iCol: Print _Trim$(Str$(arrInfo(iIndex).LeftDown)) + " ": iCol = iCol + 9
Locate iRow, iCol: Print sLine + " ": iCol = iCol + 9
Case cMouseMiddleDown:
'arrInfo(iIndex).MiddleDown = Val(sLine)
'Locate iRow, iCol: Print _Trim$(Str$(arrInfo(iIndex).MiddleDown)) + " ": iCol = iCol + 9
Locate iRow, iCol: Print sLine + " ": iCol = iCol + 9
Case cMouseRightDown:
'arrInfo(iIndex).RightDown = Val(sLine)
'Locate iRow, iCol: Print _Trim$(Str$(arrInfo(iIndex).RightDown)) + " ": iCol = iCol + 9
Locate iRow, iCol: Print sLine + " ": iCol = iCol + 9
Case Else:
' Unknown
End Select
End If
Wend
Close #1
Else
'' DEBUG OUTPUT:
'Print "File not found: " + chr$(34) + arrFile(iIndex, cFileName) + chr$(34)
End If
' -----------------------------------------------------------------------------
' GET KEYBOARD INPUT
While _DeviceInput(1): Wend ' clear and update the keyboard buffer
If _KeyDown(27) Then
Exit Do ' leave loop when ESC key pressed
End If
Next iIndex
_Limit 60 ' run 60 fps
Loop
End
' /////////////////////////////////////////////////////////////////////////////
' Returns TRUE if value OriginalString$ is numeric.
' Re: Does a Is Number function exist in QB64?
' https://www.qb64.org/forum/index.php?topic=896.15
' Version 2 by madscijr
' Returns TRUE (-1) if string is an integer, FALSE (0) if not
' Version 1 by MWheatley
' Reply #18 on: January 01, 2019, 11:24:30 AM
' returns 1 if string is an integer, 0 if not
Function IsNumber% (OriginalString$)
Dim bResult%: bResult% = FALSE
Dim iLoop%
Dim TestString$
'Dim bNegative%
Dim iDecimalCount%
Dim sNextChar$
'THEY SHOULD TRIM OUTSIDE THE FUNCTION!
'TestString$ = _TRIM$(OriginalString$)
If Len(OriginalString$) > 0 Then
TestString$ = ""
If Left$(OriginalString$, 1) = "+" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = FALSE
ElseIf Left$(OriginalString$, 1) = "-" Then
TestString$ = Right$(OriginalString$, Len(OriginalString$) - 1)
'bNegative% = TRUE
Else
TestString$ = OriginalString$
'bNegative% = FALSE
End If
If Len(TestString$) > 0 Then
bResult% = TRUE
iDecimalCount% = 0
For iLoop% = 1 To Len(TestString$)
sNextChar$ = Mid$(TestString$, iLoop%, 1)
If sNextChar$ = "." Then
iDecimalCount% = iDecimalCount% + 1
If iDecimalCount% > 1 Then
' TOO MANY DECIMAL POINTS, INVALID!
bResult% = FALSE
Exit For
End If
ElseIf Asc(sNextChar$) < 48 Or Asc(sNextChar$) > 57 Then
' NOT A NUMERAL OR A DECIMAL, INVALID!
bResult% = FALSE
Exit For
End If
Next iLoop%
End If
End If
IsNumber% = bResult%
End Function ' IsNumber%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'Combine all elements of in$() into a single string with delimiter$ separating the elements.
Function join$ (in$(), delimiter$)
result$ = in$(LBound(in$))
For i = LBound(in$) + 1 To UBound(in$)
result$ = result$ + delimiter$ + in$(i)
Next i
join$ = result$
End Function ' join$
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
Program #1: original proof of concept, doesn't really let you use regular QB64 to draw to the screen or anything (the above programs are a way to get around that):
Code: (Select All) ' ################################################################################################################################################################
' Multimouse
' ################################################################################################################################################################
' Working proof of concept! (Windows only so far)
' Plug in 2 or more USB mice and try moving them around
' For thread this was discussed at, see:
' https://qb64phoenix.com/forum/showthread.php?tid=864
' -------------------------------------------------------------------------------
' TO DO
' -------------------------------------------------------------------------------
' DONE:
' * detect mouse button clicks (left, middle, right buttons)
' Some issues and things to fix:
' * make mouse coordinates / button state / scroll wheel values
' available to a regular QB64PE program (outside of all the event driven stuff).
' Maybe make this a separate program that is underneath the main program,
' and reads the mouse coordinates and somehow passes the value back to
' the main program? Or else somehow pass the event code the main program's
' window handle, so that it reads the mouse values from the main window,
' and doesn't do anything else (the regular QB64 code draws to the screen,
' reads the keyboard input, etc.)
' * detect moving the scroll wheel
' * hide the real mouse cursor
' * get this working with _FullScreen _SquarePixels?
' * the code is seeing an extra (phantom) mouse - might be the disabled
' trackpad on my laptop. Is there a way to determine which mice or devices
' are disabled or can be ignored?
' * (later) Figure out how to do this for reading multiple keyboards.
' * (later) Figure out how to get the same functionality for Mac & Linux
' -------------------------------------------------------------------------------
' CHANGES
' -------------------------------------------------------------------------------
' DATE WHO WHAT
' 2004-04-22 jstookey added the ability to detect whether RawMouse is
' available or not so the application can either use a
' different multi-mouse system, or exit gracefully
' (thanks to Mark Healey).
' 2005-04-24 jstookey Modified the code work with the latest version of
' MinGW. The new MinGW incorporates rawinput, so my
' winuser header and library is obsolete.
' 2006-03-05 jstookey Initialized is_absolute and is_virtual_desktop to
' work better with newer versions of VStudio.
' 2022-09-07 madscijr Turned into a command line EXE that is called from
' QB64 with SpriggsySpriggs' pipecom from
' https://github.com/SpriggsySpriggs/Spriggsys-API-Collection/blob/master/Cross-Platform%20(Windows%2C%20Macintosh%2C%20Linux)/pipecomqb64.bas
' This version doesn't work.
' 2022-09-08 Spriggsy Converted C to pure QB64 code.
' 2022-09-09 madscijr Added demo code to move multiple objects on screen
' with separate mice independently.
' 2022-09-09 Spriggsy Added a screen refresh.
' 2022-09-10 madscijr Added detecting mouse buttons.
Option Explicit
_Title "multimouse"
$NoPrefix
$Console:Only
Console Off
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Const FALSE = 0
Const TRUE = Not FALSE
Const CS_HREDRAW = &H0002
Const CS_VREDRAW = &H0001
Const IDI_APPLICATION = 32512
Const IDC_ARROW = 32512
Const COLOR_WINDOW = 5
Const WS_OVERLAPPED = &H00000000
Const WS_CAPTION = &H00C00000
Const WS_SYSMENU = &H00080000
Const WS_THICKFRAME = &H00040000
Const WS_MINIMIZEBOX = &H00020000
Const WS_MAXIMIZEBOX = &H00010000
Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000
Const WS_OVERLAPPEDWINDOW = WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX
Const CW_USEDEFAULT = &H80000000
Const WM_DESTROY = &H0002
Const WM_INPUT = &H00FF
Const SW_SHOW = 5
Const RID_INPUT = &H10000003
Const RIM_TYPEMOUSE = 0
Const MOUSE_MOVE_RELATIVE = &H00
Const MOUSE_MOVE_ABSOLUTE = &H01
Const MOUSE_VIRTUAL_DESKTOP = &H02
Const MOUSE_ATTRIBUTES_CHANGED = &H04
Const MOUSE_MOVE_NOCOALESCE = &H08
Const WM_MOUSEMOVE = &H0200
Const WM_PAINT = &H000F
Const DT_CENTER = &H00000001
' MIN/MAX VALUES FOR MOUSE TEST
Const cMinX = 2
Const cMaxX = 79
Const cMinY = 16
Const cMaxY = 24
Const cMinWheel = 0
Const cMaxWheel = 255
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CONSTANTS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Type RAWINPUTDEVICE
As Unsigned Integer usUsagePage, usUsage
As Unsigned Long dwFlags
As Offset hwndTarget
End Type
Type RAWINPUTDEVICELIST
As Offset hDevice
As Unsigned Long dwType
$If 64BIT Then
As String * 4 alignment
$End If
End Type
Type POINT
As Long x, y
End Type
Type MSG
As Offset hwnd
As Unsigned Long message
As Unsigned Offset wParam
As Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
Type WNDCLASSEX
As Unsigned Long cbSize, style
As Offset lpfnWndProc
As Long cbClsExtra, cbWndExtra
As Offset hInstance, hIcon, hCursor, hbrBackground, lpszMenuName, lpszClassName, hIconSm
End Type
Type RECT
As Long left, top, right, bottom
End Type
Type PAINTSTRUCT
As Offset hdc
As Long fErase
$If 64BIT Then
As String * 4 alignment
$End If
As RECT rcPaint
As Long fRestore, fIncUpdate
As String * 32 rgbReserved
End Type
Type RAWINPUTHEADER
As Unsigned Long dwType, dwSize
As Offset hDevice
As Unsigned Offset wParam
End Type
Type RAWMOUSE
As Unsigned Integer usFlags
$If 64BIT Then
As String * 2 alignment
$End If
'As Unsigned Long ulButtons 'commented out because I'm creating this value using MAKELONG
As Unsigned Integer usButtonFlags, usButtonData
As Unsigned Long ulRawButtons
As Long lLastX, lLastY
As Unsigned Long ulExtraInformation
End Type
Type RAWINPUT
As RAWINPUTHEADER header
As RAWMOUSE mouse
End Type
' UDT TO HOLD THE INFO FOR EACH MOUSE
Type InfoType
ID As String ' mouse device ID
c As String ' cursor character
x As Integer ' screen x position
y As Integer ' screen y position
wheel As Integer ' mouse wheel value
LeftDown As Integer ' tracks left mouse button state, TRUE=down
MiddleDown As Integer ' tracks middle mouse button state, TRUE=down
RightDown As Integer ' tracks right mouse button state, TRUE=down
LeftCount As Integer ' counts left clicks
MiddleCount As Integer ' counts middle clicks
RightCount As Integer ' counts right clicks
End Type ' InfoType
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END UDTs
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Declare CustomType Library
Function GetRawInputDeviceList~& (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Sub GetRawInputDeviceList (ByVal pRawInputDeviceList As Offset, Byval puiNumDevices As Offset, Byval cbSize As Unsigned Long)
Function RegisterRawInputDevices& (ByVal pRawInputDevices As Offset, Byval uiNumDevices As Unsigned Long, Byval cbSize As Unsigned Long)
Function GetModuleHandle%& (ByVal lpModulename As Offset)
Function LoadIcon%& (ByVal hInstance As Offset, Byval lpIconName As Offset)
Function LoadCursor%& (ByVal hInstance As Offset, Byval lpCursorName As Offset)
Function RegisterClassEx~% (ByVal wndclassex As Offset)
Function CreateWindowEx%& (ByVal dwExStyle As Unsigned Long, Byval lpClassName As Offset, Byval lpWindowName As Offset, Byval dwStyle As Unsigned Long, Byval x As Long, Byval y As Long, Byval nWidth As Long, Byval nHeight As Long, Byval hWndParent As Offset, Byval hMenu As Offset, Byval hInstance As Offset, Byval lpParam As Offset)
Sub ShowWindow (ByVal hWnd As Offset, Byval nCmdShow As Long)
Sub UpdateWindow (ByVal hWnd As Offset)
Function GetMessage& (ByVal lpMsg As Offset, Byval hWnd As Offset, Byval wMsgFilterMin As Unsigned Long, Byval wMsgFilterMax As Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As Offset)
Sub DispatchMessage (ByVal lpMsg As Offset)
Sub PostQuitMessage (ByVal nExitCode As Long)
Function DefWindowProc%& (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Sub GetRawInputData (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Function GetRawInputData~& (ByVal hRawInput As Offset, Byval uiCommand As Unsigned Long, Byval pData As Offset, Byval pcbSize As Offset, Byval cbSizeHeader As Unsigned Long)
Sub InvalidateRect (ByVal hWnd As Offset, Byval lpRect As Offset, Byval bErase As Long)
Sub SendMessage (ByVal hWnd As Offset, Byval Msg As Unsigned Long, Byval wParam As Unsigned Offset, Byval lParam As Offset)
Function BeginPaint%& (ByVal hWnd As Offset, Byval lpPaint As Offset)
Sub GetClientRect (ByVal hWnd As Offset, Byval lpRect As Offset)
Sub DrawText (ByVal hdc As Offset, Byval lpchText As Offset, Byval cchText As Long, Byval lprc As Offset, Byval format As Unsigned Long)
Sub OffsetRect (ByVal lprc As Offset, Byval dx As Long, Byval dy As Long)
Sub EndPaint (ByVal hWnd As Offset, Byval lpPaint As Offset)
End Declare
' Header file "makeint.h" must be in same folder as this program.
Declare CustomType Library ".\makeint"
Function MAKEINTRESOURCE%& Alias "MAKEINTRSC" (ByVal i As _Offset)
End Declare
Declare Library
Function MAKELPARAM%& (ByVal l As Integer, Byval h As Integer)
Function MAKELONG~& (ByVal l As Unsigned Integer, Byval h As Unsigned Integer)
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\windowsx"
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\windowsx"
$End If
Function GET_Y_LPARAM& (ByVal lp As Offset)
Function GET_X_LPARAM& (ByVal lp As Offset)
End Declare
' Header file "winproc.h" must be in same folder as this program.
Declare Library ".\winproc"
Function WindowProc%& ()
End Declare
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END API DECLARATIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ENABLE / DISABLE DEBUG CONSOLE
Dim Shared m_bDebug As Integer: m_bDebug = FALSE
' BASIC PROGRAM METADATA
Dim Shared m_ProgramPath$: m_ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
Dim Shared m_ProgramName$: m_ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
' RAW INPUT VARIABLES
Dim Shared mousemessage As String
Dim Shared rawinputdevices As String
' MOUSE TEST VARIABLES
Dim Shared arrInfo(8) As InfoType ' STORES INFO FOR EACH MOUSE
'Dim Shared arrRawMouseID(8) As Long ' device IDs for mice connected to system (guessing this would be a string, dunno)
Dim Shared iMouseCount As Integer ' # OF MICE ATTACHED
Dim Shared arrScreen(1 To 80, 1 To 25) As String ' STORES TEXT FOR SCREEN
Dim Shared iMinX As Long
Dim Shared iMaxX As Long
Dim Shared iMinY As Long
Dim Shared iMaxY As Long
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GLOBAL VARIABLES
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ****************************************************************************************************************************************************************
' BEGIN ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' $Console
' _Delay 4
' _Console On
' _Echo "Started " + m_ProgramName$
' _Echo "Debugging on..."
'End If
' ****************************************************************************************************************************************************************
' END ACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' EXECUTION STARTS HERE!
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
iMinX = 0
iMaxX = 3583
iMinY = 0
iMaxY = 8202
System Val(Str$(WinMain))
' ****************************************************************************************************************************************************************
' BEGIN DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
'If m_bDebug = TRUE Then
' _Console Off
'End If
' ****************************************************************************************************************************************************************
' END DEACTIVATE DEBUGGING WINDOW
' ****************************************************************************************************************************************************************
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
System ' return control to the operating system
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END CLEANUP + FINISH
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' MOUSE CURSORS (JUST SOME LETTERS)
CData:
Data A,b,C,D,E,f,G,H
' DEFAULT/INTIAL X COORDINATE OF EACH CURSOR ON SCREEN
XData:
Data 5,15,25,35,45,55,65,75
' DEFAULT/INTIAL Y COORDINATE OF EACH CURSOR ON SCREEN
YData:
Data 17,17,19,19,21,21,23,23
' DEFAULT/INITIAL VALUE OF EACH SCROLL WHEEL
WData:
Data 224,192,160,128,96,64,32,0
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DATA
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Runs first
Function WinMain~%& ()
Dim As Offset hwndMain, hInst
Dim As MSG msg
Dim As WNDCLASSEX wndclass
Dim As String szMainWndClass
Dim As String szWinTitle
Dim As Unsigned Integer reg
'DEBUG: TRY FULL SCREEN <- PROGRAM CRASHES!
'_FullScreen _SquarePixels
hInst = GetModuleHandle(0)
szMainWndClass = "WinTestWin" + Chr$(0)
szWinTitle = "Hello" + Chr$(0)
wndclass.lpszClassName = Offset(szMainWndClass)
wndclass.cbSize = Len(wndclass)
wndclass.style = CS_HREDRAW Or CS_VREDRAW
wndclass.lpfnWndProc = WindowProc
wndclass.hInstance = hInst 'GetModuleHandle(0) will return the hInstance of this EXE
wndclass.hIcon = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hIconSm = LoadIcon(0, MAKEINTRESOURCE(IDI_APPLICATION))
wndclass.hCursor = LoadCursor(0, MAKEINTRESOURCE(IDC_ARROW))
wndclass.hbrBackground = COLOR_WINDOW + 1
reg = RegisterClassEx(Offset(wndclass)) 'I prefer to use the output of RegisterClassEx rather than the window name
'DEBUG: SUBSTITUTE _WindowHandle
hwndMain = CreateWindowEx(0, MAKELPARAM(reg, 0), Offset(szWinTitle), WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, hInst, 0)
'hwndMain = _WindowHandle
'DEBUG: SUBSTITUTE _WindowHandle
ShowWindow hwndMain, SW_SHOW
'ShowWindow _WindowHandle, SW_SHOW
'DEBUG: SUBSTITUTE _WindowHandle
UpdateWindow hwndMain
'UpdateWindow _WindowHandle
InitRawInput
InitMouseTest 'TODO: SAVE_MOUSE_INFO
While GetMessage(Offset(msg), 0, 0, 0)
TranslateMessage Offset(msg)
DispatchMessage Offset(msg)
Wend
WinMain = msg.wParam
End Function ' WinMain
' /////////////////////////////////////////////////////////////////////////////
' Handles main window events
Function MainWndProc%& (hwnd As Offset, nMsg As Unsigned Long, wParam As Unsigned Offset, lParam As Offset)
Static As Offset hwndButton
Static As Long cx, cy
Dim As Offset hdc
Dim As PAINTSTRUCT ps
Dim As RECT rc
Dim As MEM lpb
Dim As Unsigned Long dwSize
Dim As RAWINPUT raw
Dim As Long tmpx, tmpy
Static As Long maxx
Dim As RAWINPUTHEADER rih
' TEMP VARIABLES FOR DISPLAYING FORMATTED VALUES TO SCREEN
Dim strNextID As String
Dim iIndex As Integer
Dim iRowOffset As Integer
Dim iLen As Integer
Dim sCount As String
Dim sX As String
Dim sY As String
Dim sWheel As String
Dim sLeftDown As String
Dim sMiddleDown As String
Dim sRightDown As String
Dim sLeftCount As String
Dim sMiddleCount As String
Dim sRightCount As String
Dim sNext As String
Dim iNewX As Integer
Dim iNewY As Integer
Dim iDX As Integer
Dim iDY As Integer
' HANDLE EVENTS
Select Case nMsg
Case WM_DESTROY
PostQuitMessage 0
MainWndProc = 0
Exit Function
Case WM_INPUT
GetRawInputData lParam, RID_INPUT, 0, Offset(dwSize), Len(rih)
lpb = MemNew(dwSize)
If lpb.SIZE = 0 Then
MainWndProc = 0
Exit Function
End If
If GetRawInputData(lParam, RID_INPUT, lpb.OFFSET, Offset(dwSize), Len(rih)) <> dwSize Then
Print "GetRawInputData doesn't return correct size!"
End If
MemGet lpb, lpb.OFFSET, raw
If raw.header.dwType = RIM_TYPEMOUSE Then
tmpx = raw.mouse.lLastX
tmpy = raw.mouse.lLastY
maxx = tmpx
' GET MOUSE INFO
' NOTES:
' ulButtons and usButtonFlags both return the same thing (buttons)
' usButtonData changes value when scroll wheel moved (just stays at one value)
'mousemessage = ""
'mousemessage = mousemessage + "Mouse:hDevice" + Str$(raw.header.hDevice)
'mousemessage = mousemessage + "usFlags=" + Hex$(raw.mouse.usFlags)
'mousemessage = mousemessage + "ulButtons=" + Hex$(MAKELONG(raw.mouse.usButtonFlags, raw.mouse.usFlags))
'mousemessage = mousemessage + "usButtonFlags=" + Hex$(raw.mouse.usButtonFlags)
'mousemessage = mousemessage + "usButtonData=" + Hex$(raw.mouse.usButtonData)
'mousemessage = mousemessage + "ulRawButtons=" + Hex$(raw.mouse.ulRawButtons)
'mousemessage = mousemessage + "lLastX=" + Str$(raw.mouse.lLastX)
'mousemessage = mousemessage + "lLastY=" + Str$(raw.mouse.lLastY)
'mousemessage = mousemessage + "ulExtraInformation=" + Hex$(raw.mouse.ulExtraInformation) + Chr$(13)
' UPDATE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
If raw.mouse.lLastX < 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x - 1
ElseIf raw.mouse.lLastX > 0 Then
arrInfo(iIndex).x = arrInfo(iIndex).x + 1
End If
If raw.mouse.lLastY < 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y - 1
ElseIf raw.mouse.lLastY > 0 Then
arrInfo(iIndex).y = arrInfo(iIndex).y + 1
End If
' =============================================================================
'TODO: SAVE SCROLL WHEEL + BUTTONS
'Hex$(raw.mouse.usButtonFlags)
' left button = 1 when down, 2 when released
if ((raw.mouse.usButtonFlags AND 1) = 1) then
arrInfo(iIndex).LeftDown = TRUE
elseif ((raw.mouse.usButtonFlags AND 2) = 2) then
arrInfo(iIndex).LeftDown = FALSE
end if
' middle button = 16 when down, 32 when released
if ((raw.mouse.usButtonFlags AND 16) = 16) then
arrInfo(iIndex).MiddleDown = TRUE
elseif ((raw.mouse.usButtonFlags AND 32) = 32) then
arrInfo(iIndex).MiddleDown = FALSE
end if
' right button = 4 when down, 8 when released
if ((raw.mouse.usButtonFlags AND 4) = 4) then
arrInfo(iIndex).RightDown = TRUE
elseif ((raw.mouse.usButtonFlags AND 8) = 8) then
arrInfo(iIndex).RightDown = FALSE
end if
' scroll wheel = ???
'arrInfo(iIndex).wheel = ???
End If
End If
' ================================================================================================================================================================
' BEGIN DRAW PLAYING FIELD
' ================================================================================================================================================================
ClearText
WriteText 1, 1, "1. PLUG 1-8 MICE INTO THE COMPUTER"
WriteText 2, 1, "2. USE MICE TO POSITION LETTERS ON SCREEN"
WriteText 3, 1, "3. PRESS <ESC> TO QUIT"
WriteText 4, 1, "--------------------------------------------------------------------------------"
WriteText 5, 1, "# X Y Wheel LeftDown MiddleDown RightDown LeftCount MiddleCount RightCount "
WriteText 6, 1, "--------------------------------------------------------------------------------"
' NOTE: LEAVE THE NEXT 8 LINES FREE (ROWS 8-15)
' TO DISPLAY TEST VALUES FOR UPTO 8 MICE
' DRAW BORDER AROUND PLAYING FIELD
DrawTextLine cMinX - 1, cMinY - 1, cMinX - 1, cMaxY + 1, "#"
DrawTextLine cMinX - 1, cMinY - 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMaxX + 1, cMinY - 1, "#"
DrawTextLine cMaxX + 1, cMaxY + 1, cMinX - 1, cMaxY + 1, "#"
' GET INPUT AND MOVE PLAYERS
iRowOffset = 0
For iIndex = LBound(arrInfo) To UBound(arrInfo)
' CHECK BOUNDARIES
If arrInfo(iIndex).x < cMinX Then arrInfo(iIndex).x = cMinX
If arrInfo(iIndex).x > cMaxX Then arrInfo(iIndex).x = cMaxX
If arrInfo(iIndex).y < cMinY Then arrInfo(iIndex).y = cMinY
If arrInfo(iIndex).y > cMaxY Then arrInfo(iIndex).y = cMaxY
' PLOT CURSOR
WriteText arrInfo(iIndex).y, arrInfo(iIndex).x, arrInfo(iIndex).c
' DISPLAY VARIABLES
iLen = 3: sCount = Left$(LTrim$(RTrim$(Str$(iRowOffset + 1))) + String$(iLen, " "), iLen)
iLen = 3: sX = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).x))) + String$(iLen, " "), iLen)
iLen = 3: sY = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).y))) + String$(iLen, " "), iLen)
iLen = 6: sWheel = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).wheel))) + String$(iLen, " "), iLen)
iLen = 9: sLeftDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftDown))) + String$(iLen, " "), iLen)
iLen = 11: sMiddleDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleDown))) + String$(iLen, " "), iLen)
iLen = 10: sRightDown = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightDown))) + String$(iLen, " "), iLen)
iLen = 10: sLeftCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).LeftCount))) + String$(iLen, " "), iLen)
iLen = 12: sMiddleCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).MiddleCount))) + String$(iLen, " "), iLen)
iLen = 11: sRightCount = Left$(LTrim$(RTrim$(Str$(arrInfo(iIndex).RightCount))) + String$(iLen, " "), iLen)
'sNext = sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
WriteText 6 + iRowOffset, 1, sCount + sX + sY + sWheel + sLeftDown + sMiddleDown + sRightDown + sLeftCount + sMiddleCount + sRightCount
iRowOffset = iRowOffset + 1
Next iIndex
' UPDATE mousemessage WITH PLAYING FIELD
mousemessage = ScreenToString$
' ================================================================================================================================================================
' END DRAW PLAYING FIELD
' ================================================================================================================================================================
InvalidateRect hwnd, 0, -1
SendMessage hwnd, WM_PAINT, 0, 0
MainWndProc = 0
End If
MemFree lpb
MainWndProc = 0
Exit Function
Case WM_MOUSEMOVE
'mousemessage = mousemessage + "X:" + Str$(GET_X_LPARAM(lParam))
'mousemessage = mousemessage + " Y:" + Str$(GET_Y_LPARAM(lParam))
'mousemessage = mousemessage + Chr$(0)
' SAVE RANGE OF MOUSE COORDINATES
If GET_X_LPARAM(lParam) < iMinX Then iMinX = GET_X_LPARAM(lParam)
If GET_X_LPARAM(lParam) > iMaxX Then iMaxX = GET_X_LPARAM(lParam)
If GET_Y_LPARAM(lParam) < iMinY Then iMinY = GET_Y_LPARAM(lParam)
If GET_Y_LPARAM(lParam) > iMaxY Then iMaxY = GET_Y_LPARAM(lParam)
' IDENTIFY WHICH MOUSE IT IS
strNextID = _Trim$(Str$(raw.header.hDevice))
iIndex = GetMouseIndex%(strNextID)
If iIndex >= LBound(arrInfo) Then
If iIndex <= UBound(arrInfo) Then
' =============================================================================
' UPDATE ABSOLUTE POSITION
' DOESN'T WORK, MOVES ALL OVER THE PLACE:
'' METHOD #1: SCALE MOUSE POSITION TO 80X25 POSITION
''iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ 1520
'iNewX = ( (GET_X_LPARAM(lParam) + 1) * 80) \ (iMaxX+1)
''iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ 782
'iNewY = ( (GET_Y_LPARAM(lParam) + 1) * 25) \ (iMaxY+1)
'arrInfo(iIndex).x = iNewX
'arrInfo(iIndex).y = iNewY
' WORKS BUT NOT THAT ACCURATE:
' METHOD #2: INCREMENT/DECREMENT DELTA
' (should we update here too?)
'TODO: SAVE SCROLL WHEEL + BUTTONS
' (should we update here too?)
'arrInfo(iIndex).wheel =
'arrInfo(iIndex).LeftDown =
'arrInfo(iIndex).MiddleDown =
'arrInfo(iIndex).RightDown =
End If
End If
'DEBUG: SUBSTITUTE _WindowHandle
InvalidateRect hwnd, 0, -1
'InvalidateRect _WindowHandle, 0, -1
'DEBUG: SUBSTITUTE _WindowHandle
SendMessage hwnd, WM_PAINT, 0, 0
'SendMessage _WindowHandle, WM_PAINT, 0, 0
MainWndProc = 0
Exit Function
Case WM_PAINT
'DEBUG: SUBSTITUTE _WindowHandle
hdc = BeginPaint(hwnd, Offset(ps))
'hdc = BeginPaint(_WindowHandle, Offset(ps))
'DEBUG: SUBSTITUTE _WindowHandle
GetClientRect hwnd, Offset(rc)
'GetClientRect _WindowHandle, Offset(rc)
DrawText hdc, Offset(mousemessage), Len(mousemessage), Offset(rc), DT_CENTER
OffsetRect Offset(rc), 0, 200
'' PRINT LIST OF RawInput DEVICES:
'DrawText hdc, Offset(rawinputdevices), Len(rawinputdevices), Offset(rc), DT_CENTER
'DEBUG: SUBSTITUTE _WindowHandle
EndPaint hwnd, Offset(ps)
'EndPaint _WindowHandle, Offset(ps)
MainWndProc = 0
Exit Function
Case Else
'DEBUG: SUBSTITUTE _WindowHandle
MainWndProc = DefWindowProc(hwnd, nMsg, wParam, lParam)
'MainWndProc = DefWindowProc(_WindowHandle, nMsg, wParam, lParam)
End Select
End Function ' MainWndProc
' /////////////////////////////////////////////////////////////////////////////
' Initializes raw input stuff
Sub InitRawInput ()
Dim As RAWINPUTDEVICE Rid(0 To 49)
Dim As Unsigned Long nDevices
Dim As RAWINPUTDEVICELIST RawInputDeviceList
Dim As MEM pRawInputDeviceList
ReDim As RAWINPUTDEVICELIST rawdevs(-1)
Dim As Unsigned Long x
Dim strNextID As String
'dim lngNextID as long
If GetRawInputDeviceList(0, Offset(nDevices), Len(RawInputDeviceList)) <> 0 Then
Exit Sub
End If
pRawInputDeviceList = MemNew(Len(RawInputDeviceList) * nDevices)
GetRawInputDeviceList pRawInputDeviceList.OFFSET, Offset(nDevices), Len(RawInputDeviceList)
' This small block of commented code proves that we've got the device list
ReDim As RAWINPUTDEVICELIST rawdevs(0 To nDevices - 1)
MemGet pRawInputDeviceList, pRawInputDeviceList.OFFSET, rawdevs()
' GET MOUSE INFO
iMouseCount = 0
rawinputdevices = "Number of raw input devices:" + Str$(nDevices) + Chr$(13)
For x = 0 To UBound(rawdevs)
rawinputdevices = rawinputdevices + Str$(rawdevs(x).hDevice) + ":" + Str$(rawdevs(x).dwType) + Chr$(13)
' Is it a mouse?
'TODO: SAVE_MOUSE_INFO
If rawdevs(x).dwType = 0 Then
iMouseCount = iMouseCount + 1
strNextID = _Trim$(Str$(rawdevs(x).hDevice))
'lngNextID = Val(strNextID)
'arrInfo(iMouseCount-1).ID = lngNextID
arrInfo(iMouseCount - 1).ID = strNextID
End If
Next x
rawinputdevices = rawinputdevices + Chr$(0)
MemFree pRawInputDeviceList
Rid(0).usUsagePage = &H01
Rid(0).usUsage = &H02
Rid(0).dwFlags = 0
'DEBUG: SUBSTITUTE _WindowHandle
Rid(0).hwndTarget = 0
'Rid(0).hwndTarget = _WindowHandle
If RegisterRawInputDevices(Offset(Rid()), 1, Len(Rid(0))) = 0 Then
mousemessage = "RawInput init failed" + Chr$(0)
End If
End Sub ' InitRawInput
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END RAW INPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Initialize mouse test stuff
'TODO: SAVE_MOUSE_INFO
Sub InitMouseTest
Dim iIndex As Integer
Dim iLoop As Integer
' FOR NOW ONLY SUPPORT UPTO 8 MICE
If (iMouseCount > 8) Then iMouseCount = 8
' INITIALIZE CURSORS, MOUSE STATE, ETC.
Restore CData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).c
' INITIALIZED BELOW: arrInfo(iIndex).x = 0
' INITIALIZED BELOW: arrInfo(iIndex).y = 0
' INITIALIZED BELOW: arrInfo(iIndex).wheel = 127
arrInfo(iIndex).LeftDown = FALSE
arrInfo(iIndex).MiddleDown = FALSE
arrInfo(iIndex).RightDown = FALSE
arrInfo(iIndex).LeftCount = 0
arrInfo(iIndex).MiddleCount = 0
arrInfo(iIndex).RightCount = 0
Next iLoop
' INITIALIZE X COORDINATES
Restore XData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).x
Next iLoop
' INITIALIZE Y COORDINATES
Restore YData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).y
Next iLoop
' INITIALIZE SCROLL WHEEL
Restore WData
iIndex = LBound(arrInfo) - 1
For iLoop = 1 To iMouseCount
iIndex = iIndex + 1
Read arrInfo(iIndex).wheel
Next iLoop
End Sub ' InitMouseTest
' /////////////////////////////////////////////////////////////////////////////
' Finds position in array arrInfo where .ID = MouseID
Function GetMouseIndex% (MouseID As String)
Dim iLoop As Integer
Dim iIndex%
iIndex% = LBound(arrInfo) - 1
For iLoop = LBound(arrInfo) To UBound(arrInfo)
If arrInfo(iLoop).ID = MouseID Then
iIndex% = iLoop
Exit For
Else
' not it
End If
Next iLoop
GetMouseIndex% = iIndex%
End Function ' GetMouseIndex%
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE TEST FUNCTIONS #1
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Clears global array arrScreen
Sub ClearText
Dim iColNum As Integer
Dim iRowNum As Integer
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
arrScreen(iColNum, iRowNum) = " "
Next iRowNum
Next iColNum
End Sub ' ClearText
' /////////////////////////////////////////////////////////////////////////////
' Plots string MyString to position (iX, iY) in global array arrScreen.
Sub WriteText (iRow As Integer, iColumn As Integer, MyString As String)
Dim iPos As Integer
Dim iLoop As Integer
If iColumn > 0 And iColumn < 81 Then
If iRow > 0 And iRow < 26 Then
For iLoop = 1 To Len(MyString)
iPos = iColumn + (iLoop - 1)
If iPos < 81 Then
arrScreen(iPos, iRow) = Mid$(MyString, iLoop, 1)
Else
Exit For
End If
Next iLoop
End If
End If
End Sub ' WriteText
' /////////////////////////////////////////////////////////////////////////////
' Converts global array arrScreen to a string.
Function ScreenToString$
Dim sResult As String
Dim iColNum As Integer
Dim iRowNum As Integer
sResult = ""
For iRowNum = LBound(arrScreen, 2) To UBound(arrScreen, 2)
For iColNum = LBound(arrScreen, 1) To UBound(arrScreen, 1)
sResult = sResult + arrScreen(iColNum, iRowNum)
Next iColNum
sResult = sResult + Chr$(13)
Next iRowNum
ScreenToString$ = sResult
End Function ' ScreenToString$
' /////////////////////////////////////////////////////////////////////////////
' based on code from:
' Qbasic Programs - Download free bas source code
' http://www.thedubber.altervista.org/qbsrc.htm
Sub DrawTextLine (y%, x%, y2%, x2%, c$)
Dim i%
Dim steep%
Dim e%
Dim sx%
Dim dx%
Dim sy%
Dim dy%
i% = 0: steep% = 0: e% = 0
If (x2% - x%) > 0 Then sx% = 1: Else sx% = -1
dx% = Abs(x2% - x%)
If (y2% - y%) > 0 Then sy% = 1: Else sy% = -1
dy% = Abs(y2% - y%)
If (dy% > dx%) Then
steep% = 1
Swap x%, y%
Swap dx%, dy%
Swap sx%, sy%
End If
e% = 2 * dy% - dx%
For i% = 0 To dx% - 1
If steep% = 1 Then
''PSET (y%, x%), c%:
'Locate y%, x% : Print c$;
WriteText y%, x%, c$
Else
''PSET (x%, y%), c%
'Locate x%, y% : Print c$;
WriteText x%, y%, c$
End If
While e% >= 0
y% = y% + sy%: e% = e% - 2 * dx%
Wend
x% = x% + sx%: e% = e% + 2 * dy%
Next
''PSET (x2%, y2%), c%
'Locate x2%, y2% : Print c$;
WriteText x2%, y2%, c$
End Sub ' DrawTextLine
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END TEST OUTPUT FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' Returns a count of # of RawInput mouse devices connected to the system
' *****************************************************************************
' TODO: GET COUNT FROM RawInput API
' For now, hardcoded to 1 until we figure out how to do this.
' *****************************************************************************
Function GetRawMouseCount% ()
GetRawMouseCount% = 1
End Function ' GetRawMouseCount%
' /////////////////////////////////////////////////////////////////////////////
' Gets ID of each RawInput mouse device connected to the system (for now upto 8)
' Returns the IDs in an array of LONG <- may change depending on whether
' we save each the device handle for each mouse or the index
' If no mouse found, the ID will just be 0 <- or whatever value we decide as default/none
' *****************************************************************************
' TODO: GET THIS FROM RawInput API
' For now, hardcoded arrRawMouseID(1) to 1, and the rest 0, until we figure out how to do this.
' *****************************************************************************
'Sub GetRawMouseIDs (arrRawMouseID( 8) As Integer)
Sub GetRawMouseIDs ()
Dim iLoop As Integer
' CLEAR OUT IDs
For iLoop = 1 To 8
''arrRawMouseID(iLoop) = 0
'arrInfo(iLoop).ID = 0
arrInfo(iLoop).ID = ""
Next iLoop
' GET IDs
'TODO: get this from RawInput API
''arrRawMouseID(1) = 1 ' for now just fudge it!
'arrInfo(0).ID = 1 ' for now just fudge it!
End Sub ' GetRawMouseIDs
' /////////////////////////////////////////////////////////////////////////////
' Read mouse using RawInput API
' Gets input from mouse, MouseID% = which mouse
' NOTE: click events (mouse up/mouse down) are handled by the calling sub,
' this routine just sends back
' TRUE if the given button is currently down or FALSE if it is up.
' Parameters (input only):
' MouseID% = which mouse to return input for
' wheelMin% = minimum value to allow wheelValue% to be decremented to
' wheelMax% = maximum value to allow wheelValue% to be incremened to
' Parameters (values returned):
' x% = mouse x position
' y% = mouse y position
' leftButton% = current state of left mouse button (up or down)
' middleButton% = current state of middle mouse button / scroll wheel button (up or down)
' rightButton% = current state of right mouse button (up or down)
' wheelValue% = value of mouse scroll wheel (passed in and incremented/decremented by 1 if wheel move detected)
Sub ReadRawMouse (MouseID%, x%, y%, leftButton%, middleButton%, rightButton%, wheelValue%, wheelMin%, wheelMax%)
Dim scrollAmount%
Dim dx%
Dim dy%
' =============================================================================
' BEGIN READ MOUSE THE NEW RawInput WAY:
' read scroll wheel
'TODO: get this from RawInput API
' determine mouse x position
'TODO: get this from RawInput API
dx% = 0 ' = getMouseDx(MouseID%)
x% = x% + dx% ' adjust mouse value by dx
' determine mouse y position
'TODO: get this from RawInput API
dy% = 0 ' = getMouseDy(MouseID%)
y% = y% + dy% ' adjust mouse value by dx
' read mouse buttons
'TODO: get this from RawInput API
leftButton% = FALSE
middleButton% = FALSE
rightButton% = FALSE
' END READ MOUSE THE NEW RawInput WAY:
' =============================================================================
' =============================================================================
' BEGIN READ MOUSE THE OLD QB64 WAY:
'
'' read scroll wheel
'WHILE _MOUSEINPUT ' get latest mouse information
' scrollAmount% = _MOUSEWHEEL ' (Returns -1 when scrolling up and 1 when scrolling down with 0 indicating no movement since last read.)
' IF (scrollAmount% = -1) AND (wheelValue% > wheelMin%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' ELSEIF (scrollAmount% = 1) AND (wheelValue% < wheelMax%) THEN
' wheelValue% = wheelValue% + scrollAmount%
' END IF
'WEND
'
'' determine mouse x position
'x% = _MOUSEX
'
'' determine mouse y position
'y% = _MOUSEY
'
'' read mouse buttons
'leftButton% = _MOUSEBUTTON(1)
'middleButton% = _MOUSEBUTTON(3)
'rightButton% = _MOUSEBUTTON(2)
'
' END READ MOUSE THE OLD QB64 WAY:
' =============================================================================
End Sub ' ReadRawMouse
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END MOUSE FUNCTIONS TO COME
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' /////////////////////////////////////////////////////////////////////////////
' FOR BITWISE OPERATIONS
function HasBit%(iByte as integer, iBit as integer)
''TODO: precalculate
'dim shared m_arrBitValue(1 To 8) As Integer
'dim iLoop as Integer
'For iLoop = 0 To 7
' m_arrBitValue(iLoop + 1) = 2 ^ iLoop
'Next iLoop
'HasBit% = ((iByte And m_arrBitValue(iBit)) = m_arrBitValue(iBit))
Dim iBitValue As Integer
iBitValue = 2 ^ (iBit-1)
HasBit% = ( (iByte And iBitValue) = iBitValue)
end function ' HasBit%
' /////////////////////////////////////////////////////////////////////////////
' Split and join strings
' https://www.qb64.org/forum/index.php?topic=1073.0
'
' FROM luke, QB64 Developer
' Date: February 15, 2019, 04:11:07 AM
'
' Given a string of words separated by spaces (or any other character),
' splits it into an array of the words. I've no doubt many people have
' written a version of this over the years and no doubt there's a million
' ways to do it, but I thought I'd put mine here so we have at least one
' version. There's also a join function that does the opposite
' array -> single string.
'
' Code is hopefully reasonably self explanatory with comments and a little demo.
' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
'
'delimiter$ must be one character long.
'result$() must have been REDIMmed previously.
' Modified to handle multi-character delimiters
Sub split (in$, delimiter$, result$())
Dim start As Integer
Dim finish As Integer
Dim iDelimLen As Integer
ReDim result$(-1)
iDelimLen = Len(delimiter$)
start = 1
Do
'While Mid$(in$, start, 1) = delimiter$
While Mid$(in$, start, iDelimLen) = delimiter$
'start = start + 1
start = start + iDelimLen
If start > Len(in$) Then
Exit Sub
End If
Wend
finish = InStr(start, in$, delimiter$)
If finish = 0 Then
finish = Len(in$) + 1
End If
ReDim _Preserve result$(0 To UBound(result$) + 1)
result$(UBound(result$)) = Mid$(in$, start, finish - start)
start = finish + 1
Loop While start <= Len(in$)
End Sub ' split
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END GENERAL PURPOSE FUNCTIONS
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' BEGIN DEBUGGING ROUTINES #DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'' /////////////////////////////////////////////////////////////////////////////
'
'Sub DebugPrint (MyString As String)
' If m_bDebug = TRUE Then
' '_Echo MyString
' ReDim arrLines(-1) As String
' Dim iLoop As Integer
' split MyString, Chr$(13), arrLines()
' For iLoop = LBound(arrLines) To UBound(arrLines)
' _Echo arrLines(iLoop)
' Next iLoop
' End If
'End Sub ' DebugPrint
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' END DEBUGGING ROUTINES @DEBUGGING
' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ################################################################################################################################################################
' #REFERENCE
' =============================================================================
' SOME USEFUL STUFF FOR REFERENCE:
' Type Name Type suffix symbol Minimum value Maximum value Size in Bytes
' --------------------- ------------------ ---------------------------- -------------------------- -------------
' _BIT ` -1 0 1/8
' _BIT * n `n -128 127 n/8
' _UNSIGNED _BIT ~` 0 1 1/8
' _BYTE %% -128 127 1
' _UNSIGNED _BYTE ~%% 0 255 1
' INTEGER % -32,768 32,767 2
' _UNSIGNED INTEGER ~% 0 65,535 2
' LONG & -2,147,483,648 2,147,483,647 4
' _UNSIGNED LONG ~& 0 4,294,967,295 4
' _INTEGER64 && -9,223,372,036,854,775,808 9,223,372,036,854,775,807 8
' _UNSIGNED _INTEGER64 ~&& 0 18,446,744,073,709,551,615 8
' SINGLE ! or none -2.802597E-45 +3.402823E+38 4
' DOUBLE # -4.490656458412465E-324 +1.797693134862310E+308 8
' _FLOAT ## -1.18E-4932 +1.18E+4932 32(10 used)
' _OFFSET %& -9,223,372,036,854,775,808 9,223,372,036,854,775,807 Use LEN
' _UNSIGNED _OFFSET ~%& 0 18,446,744,073,709,551,615 Use LEN
' _MEM none combined memory variable type N/A Use LEN
' div: int1% = num1% \ den1%
' mod: rem1% = num1% MOD den1%
' @END
|
|
|
|
| abikox (game like hanoi) |
|
Posted by: hsiangch_ong - 05-20-2024, 06:38 PM - Forum: Programs
- Replies (1)
|
 |
this program should be able to run in any version of phoenix qb64. credit for the playmusak program is given to user mnrvovrfc.
this is the twist to a popular game. i admit, it was brutally put together. it should be easy enough to figure it out. my best score was 28.
Code: (Select All)
OPTION _EXPLICIT
CONST GAMELABEL = "ABIKOX"
DIM kox(1 TO 4) AS STRING
DIM AS STRING path2font, myk, oldk, ESCAP
DIM AS LONG cyfont, movcount
DIM AS INTEGER i, j, h, v, m, g, x, onechar, musakcounter
DIM tiltenable AS _BIT
ESCAP = CHR$(27)
$IF WIN THEN
'change this to taste:
path2font = "C:\Windows\Fonts\cyberbit.ttf"
$ELSE
path2font = ENVIRON$("HOME") + "/.local/share/fonts/cyberbit.ttf"
$END IF
kox(1) = SPACE$(6)
kox(2) = kox(1)
kox(3) = kox(1)
kox(4) = GAMELABEL
RANDOMIZE VAL(RIGHT$(TIME$, 2))
tiltenable = 0
musakcounter = 0
oldk = ""
SCREEN _NEWIMAGE(800, 600, 12)
cyfont = _LOADFONT(path2font, 32)
_FONT cyfont
_SCREENMOVE _MIDDLE
_DISPLAY
playmusak musakcounter
DO UNTIL kox(1) = GAMELABEL OR kox(2) = GAMELABEL OR kox(3) = GAMELABEL
movcount = movcount + 1
CLS
COLOR 15
FOR j = 1 TO 4
FOR i = 1 TO 6
onechar = ASC(kox(j), i)
IF onechar = 32 THEN onechar = 124
_PRINTSTRING (j * 40, i * 40), CHR$(onechar)
NEXT
NEXT
_DISPLAY
DO: myk = INKEY$: LOOP UNTIL myk = ""
playmusak musakcounter
DO
_LIMIT 100
myk = INKEY$
LOOP WHILE myk = ""
IF myk = ESCAP THEN EXIT DO
SELECT CASE myk
CASE "A", "B", "I", "K", "O", "X"
CASE "a", "b", "i", "k", "o", "x"
myk = CHR$(ASC(myk) - 32)
CASE ELSE
_CONTINUE
END SELECT
tiltenable = 0
IF myk = oldk THEN tiltenable = NOT tiltenable
h = 0: v = 0
FOR j = 1 TO 4
FOR i = 1 TO 6
IF MID$(kox(j), i, 1) = myk THEN
h = j
v = i
EXIT FOR
END IF
NEXT
IF h > 0 THEN EXIT FOR
NEXT
IF v > 1 THEN
IF ASC(kox(h), v - 1) <> 32 THEN
COLOR 5
_PRINTSTRING (0, 500), "ILLEGAL"
_PRINTSTRING (40, 540), "MOVE"
_DISPLAY
_DELAY 1
_CONTINUE
END IF
END IF
FOR j = 1 TO 4
IF h <> j THEN
g = 0: m = 0
FOR i = 1 TO 6
IF ASC(kox(j), i) <> 32 THEN
m = i
g = j
EXIT FOR
END IF
NEXT
IF m = 0 THEN
m = 6
g = j
IF tiltenable THEN
tiltenable = 0
_CONTINUE
ELSE
EXIT FOR
END IF
END IF
IF ASC(kox(h), v) < ASC(kox(g), m) THEN
m = m - 1
IF tiltenable THEN
tiltenable = 0
_CONTINUE
ELSE
EXIT FOR
END IF
ELSE
g = 0
END IF
END IF
NEXT
IF g > 0 THEN
ASC(kox(g), m) = ASC(kox(h), v)
ASC(kox(h), v) = 32
ELSE
COLOR 6
_PRINTSTRING (0, 500), "NO MOVE"
_PRINTSTRING (0, 540), "POSSIBLE"
_DISPLAY
_DELAY 2
END IF
oldk = myk
LOOP
IF myk <> ESCAP THEN
IF kox(1) = GAMELABEL THEN x = 1
IF kox(2) = GAMELABEL THEN x = 2
IF kox(3) = GAMELABEL THEN x = 3
CLS
FOR j = 1 TO 4
IF x = j THEN COLOR 4 ELSE COLOR 15
FOR i = 1 TO 6
onechar = ASC(kox(j), i)
IF onechar = 32 THEN onechar = 124
_PRINTSTRING (j * 40, i * 40), CHR$(onechar)
NEXT
NEXT
COLOR 14
_PRINTSTRING (0, 500), "YOU WIN"
_PRINTSTRING (0, 540), LTRIM$(STR$(movcount)) + " MOVES"
_DISPLAY
_DELAY 5
END IF
SYSTEM
'note: "round" is changed by this subprogram
SUB playmusak (round AS INTEGER)
round = round + 1
SELECT CASE round
CASE 1
PLAY "MBT160O3"
CASE 2
PLAY "L8C<A>G-L16CCL8CG-C<A>G-C<A>C<A>G-C<A>CG-<A>C<A>G-"
CASE 3
PLAY "E-CE-CE-CFE-L16CCL8CCL8E-FE-CE-C"
CASE 4
PLAY "E-CFC<A>G-C<A>C<A>G-E-CFL16E-E-L8E-FE-L16CCL8CE-CFE-"
CASE 5
PLAY "CE-CE-CFC<A>C<A>C<A>G-E-CFE-CE-CFC<A>CG-"
CASE 6
PLAY "<A>C<A>G-E-L16CCL8CCL8E-FE-CE-CE-CFC<A>C<A>C<A>G-"
CASE 7
PLAY "C<A>C<A>C<A>G-E-CFE-CE-CFE-CE-CE-CFC<A>C"
CASE 8
PLAY "<A>C<A>G-E-CE-FCE-CFE-CFL16E-E-L8E-FC<A>C<A>C<A>G-E-"
CASE 9
PLAY "CE-CE-CFC<A>C<A>C<A>G-E-CE-CE-CFE-CCE-CF"
CASE 10
PLAY "E-C<A>G-C<A>C<A>G-E-CFE-CE-CFC<A>G-C<A>C<A>G-C"
CASE 11
PLAY "L16<A><A>L8<A><A>L8CG-E-CCE-CFE-C<A>C<A>C<A>"
CASE 12
PLAY "G-E-CE-CE-CFE-CE-CE-CFE-CFE-CE-CFE-CCE-CFE-E-CFE-CE-"
CASE 13
PLAY "CFC<A>C<A>C<A>G-C<A>G-C<A>C<A>G-E-CFL16E-"
CASE 14
PLAY "E-L8E-FC<A>C<A>C<A>G-E-CE-CE-CFC<A>C<A>C<A>G-E-CE-CE-"
CASE 15
PLAY "CFE-CE-CE-CFE-CFE-CE-CFC<A>G-C<A>C<A>G-C"
CASE 16
PLAY "<A>G-C<A>C<A>G-C<A>G-C<A>C<A>G-C<A>C<A>C<A>G-C<A>C<A>"
CASE 17
PLAY "C<A>G-E-CFE-CE-CFC<A>C<A>C<A>G-C<A>CG-"
CASE 18
PLAY "<A>C<A>G-E-CFE-CE-CFE-CE-CE-CFE-CFL16E-E-L8E-FE-CCE-"
CASE 19
PLAY "CFE-E-CE-E-CE-FE-CE-CE-CFE-L16CCL8CC"
CASE 20
PLAY "L8E-FE-CFE-CE-CFC<A>G-C<A>C<A>G-E-CCE-CFE-E-CE-FCE-"
CASE 21
PLAY "CFE-CE-CE-CFE-CE-CE-CFC<A>CG-<A>C<A>G-C<A>"
CASE 22
PLAY "<A>C<A>G-CC<A>C<A>C<A>G-CL16<A><A>L8<A>C<A>G-E-CFE-"
CASE 23
PLAY "CE-CFC<A><A>C<A>G-CC<A><A>C<A>G-C"
CASE 24
round = 0
END SELECT
END SUB
[START ENTRY]
ABIKOX
Hsiang Ch'ung
game, tower
it is a twist of the popular game.
the same key could be pressed to move its tile but it could
erroneously indicate "no move possible". this is intentional.
[END ENTRY]
|
|
|
|
| Input routine |
|
Posted by: dano - 05-20-2024, 05:10 PM - Forum: General Discussion
- Replies (9)
|
 |
Does anyone know of a Windows-like input routine that has been written for QB64? Something that accepts mouse input, cut & paste, word wrap, etc.
I have looked through the forums and did not find anything.
Thanks in advance,
Dano
|
|
|
|
| qbjs & qb64pe compatibility and equivalent for other languages like Python? |
|
Posted by: madscijr - 05-20-2024, 04:06 PM - Forum: General Discussion
- Replies (10)
|
|
I'm finally getting around to being curious about qbjs - what features of QB64PE does it not support?
I'm thinking that a fully portable interpreter that runs in a browser, even locally, would be great for playing with other languages like Python, without having to install them on your system. Is there a qbjs equivalent for Python, Pascal, Lua, or any other cool languages?
Thanks
|
|
|
|
| Extended KotD #9: _WRITEFILE |
|
Posted by: SMcNeill - 05-20-2024, 05:34 AM - Forum: Keyword of the Day!
- No Replies
|
 |
The last of the new keywords and enhancements for v3.12 is _WriteFile. Like _ReadFile$, it's a simple shortcut which can help reduce multiple commands into one simple process.
In the past, one would have to do the following to write a binary file to the drive:
Code: (Select All) F = FreeFile
Open "temp.txt" For Output As #F
Close F
Open "temp.txt" For Binary As #F
PUT #F, 1, your_string$
Close #F
Now, however, since v3.12, one can replace all the above code with the following:
Code: (Select All) _WriteFile "temp.txt", your_string$
No need to get a file handle. No need to open the file FOR OUTPUT to make certain it's blank and you're not corrupting a previous file with the same name. No need to close that handle and then reopen another FOR BINARY to write the file...only to have to close it once again.
Just a simple _WriteFile file$, string_to_write$
That's all there is for this little shortcut command! 
|
|
|
|
| Bug in IDE v3.13.1 |
|
Posted by: dano - 05-19-2024, 08:50 PM - Forum: GitHub Discussion
- Replies (3)
|
|
Two Bugs:
First:
In the IDE create the line: Goto ThisLabel.undefined
If the above label is in your program - great...everything works.
If the above label is missing, the IDE reports the error:
Label 'ThisLabel__ASCII_CHR_046__undefined' not defined
So basically if you point to a missing label that has a period in it, it will replace the period with __ASCII_CHR_046__
--------------------------------------
Second (this one existed before v3.13.1):
Press CtrlF
Enter a search term (without pressing ENTER)
While still in the search term entry field, either press the HOME key or left arrow so that you can have the cursor over existing text.
Press the DELETE key. Sometimes it enters a SPACE and sometimes it just exits the search term entry field, but never does it delete the character.
Not biggies...just reporting when I find them.
|
|
|
|
| A very simple game of matches |
|
Posted by: Delsus - 05-19-2024, 04:39 PM - Forum: Games
- No Replies
|
|
Hello!
I thought I would share a very short game in which the goal is to not remove the last match to win.
Code: (Select All)
' Declare variables
DIM matches AS INTEGER
DIM turn AS INTEGER
DIM player1Matches AS INTEGER
DIM player2Matches AS INTEGER
DIM inputPick AS STRING
' Set initial number of matches
matches = 20
' Randomly choose starting player
turn = RND(2) ' 1 for player 1, 2 for player 2
' Game loop
DO WHILE matches > 0
' Display current state
CLS
Print ""
Color 7
Print "ßßßßßßßßßßßßß";
Color 4
print "ß"
Color 15
Print ""
PRINT "Matches left: " + STR$(matches)
PRINT "Player 1 matches" + STR$(player1Matches)
PRINT "Player 2 matches" + STR$(player2Matches)
Print ""
Color 7
Print "ßßßßßßßßßßßßß";
Color 4
print "ß"
Color 15
' Turn of current player
IF turn = 1 THEN
PRINT "Player 1's turn - Select 1, 2 or 3 matches to remove: "
ELSE
PRINT "Player 2's turn - Select 1, 2 or 3 matches to remove: "
END IF
' Get player input and validate
DO
inputPick = INKEY$
LOOP UNTIL (VAL(inputPick) >= 1) AND (VAL(inputPick) <= 3) AND (VAL(inputPick) <= matches)
pick = VAL(inputPick) ' Convert to integer here
' Update matches and current player
matches = matches - pick
IF turn = 1 THEN
player1Matches = player1Matches + pick
turn = 2
ELSE
player2Matches = player2Matches + pick
turn = 1
END IF
LOOP
' Declare winner
CLS
IF turn = 1 THEN
PRINT "Player 1 wins!"
ELSE
PRINT "Player 2 wins!"
END IF
Sleep
' End message
PRINT "Press any key"
Sleep
END
|
|
|
|
|
