Lately I have been working on getting the combat console working and the beginnings of actual combat.
I have it on my github if you are wanting to check it out and give me some feedback. Because it is part of the fzxNGN it is hosted with it in my github. https://github.com/mechatronic3000/fzxNGN
Forgive me, I have not updated the github readme to reflect that it is there. Its under the RougeLike directory.
Posted by: SMcNeill - 09-27-2023, 05:30 AM - Forum: SMcNeill
- No Replies
As per posts in a few different topics, here's a simple way to determine if a mouse is inside the program window or not. (This works just for Windows, but you Linux/Mac guys should be able to substitute for whatever the equivalent of the Windows API call of GetCursorPos is. I just don't know your OS commands good enough to know what to use for it.)
These programs ARE PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND.
THE AUTHOR DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR IMPLIED, INCLUDING
THE WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
IN NO EVENT SHALL THE AUTHOR OR ANY SUPPLIER BE LIABLE FOR ANY DAMAGES
WHATSOEVER INCLUDING DIRECT, INDIRECT, INCIDENTAL, CONSEQUENTIAL, LOSS OF
BUSINESS PROFITS OR SPECIAL DAMAGES, EVEN IF THE AUTHOR OR ANY SUPPLIER HAS
BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF LIABILITY FOR
CONSEQUENTIAL OR INCIDENTAL DAMAGES SO THE FOREGOING LIMITATION MAY NOT
APPLY. PLEASE CHECK WITH YOUR LOCAL AND STATE AGENCIES FOR INFORMATION
ABOUT ANY APPLIED RESPONSIBILITIES REGARDING THE ABOVE NOTICES.
Author: Erik Jon Oredson
Email: eoredson@gmail.com
These programs and its source public domain 2023.
Code: (Select All)
Rem The nasty volume delete program v1.1a PD 2023.
DefLng A-Z
' declare external libraries.
Dim Shared DriveType As String
Dim Shared ErrorBuffer As String * 260
Const MAX_PATH = 260
Declare Library
Function GetDriveType& (d$)
End Declare
Declare Dynamic Library "Shell32"
Function IsUserAnAdmin& ()
Sub ShellExecute Alias "ShellExecuteA" (ByVal hwnd As _Offset, lpOperation As String, lpFile As String, lpParameters As String, Byval lpDirectory As _Offset, Byval nShowCmd As Long)
End Declare
Declare Dynamic Library "kernel32"
Function GetVolumeInformationA& (lpRootPathName$, lpVolumeNameBuffer$, Byval nVolumeNameSize~&, lpVolumeSerialNumber~&, lpMaximumComponentLength~&, lpFileSystemFlags~&, lpFileSystemNameBuffer$, Byval nFileSystemNameSize&)
Function SetVolumeLabelA% (d$, f$)
Function GetLastError& ()
Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)
End Declare
If IsUserAnAdmin = 0 Then
Call ShellExecute(0, "runas" + Chr$(0), Command$(0) + Chr$(0), Command$ + Chr$(0), 0, 5)
System
End If
Color 15
v$ = "Are you sure you want to remove all volume labels(y/n)? "
Print v$;
Do
_Limit 50
x$ = InKey$
If x$ <> "" Then
Exit Do
End If
Loop
Print
If LCase$(x$) = "y" Then
f = 0
For Z = 1 To 26
f$ = UCase$(Chr$(Z + 64))
v = GetDriveExists(f$)
If v Then
' get drive info.
VarX$ = f$ + ":\" + Chr$(0)
Vname$ = Space$(MAX_PATH)
Fname$ = Space$(MAX_PATH)
r = GetVolumeInformationA(VarX$, Vname$, MAX_PATH, serial~&, empty1~&, empty2~&, Fname$, MAX_PATH)
If r = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " reading drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(r)
Else
' change volume label
f$ = f$ + ":\" + Chr$(0)
g$ = "" + Chr$(0)
x = SetVolumeLabelA%(f$, g$)
If x = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " accessing drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(x)
Else
Print "Volume "; Chr$(Z + 64); ":\ zapped."
f = f + 1
End If
End If
End If
Next
Color 14
If f Then
Print "Volume labels zapped:"; f
Else
Print "No volume labels zapped."
End If
Color 15
Print "-more-";
While InKey$ = ""
_Limit 50
Wend
Print
End If
End
' return -1 if drive exists
Function GetDriveExists (V$)
If UCase$(V$) = "A" Or UCase$(V$) = "B" Then
DriveType = "[FLOPPY]"
GetDriveExists = -1
Exit Function
End If
VarX$ = V$ + ":\" + Chr$(0)
VarX = GetDriveType(VarX$)
DriveType = ""
Select Case VarX
Case 0
DriveType = "[UNKNOWN]"
Case 1
DriveType = "[BADROOT]"
Case 2
DriveType = "[REMOVABLE]"
Case 3
DriveType = "[FIXED]"
Case 4
DriveType = "[REMOTE]"
Case 5
DriveType = "[CDROM]"
Case 6
DriveType = "[RAMDISK]"
End Select
If VarX > 1 Then
GetDriveExists = -1
Else
GetDriveExists = 0
End If
End Function
' display windows error message
Function DisplayWinError$ (x)
' define error message value
v& = GetLastError
' call windows error message routine
x& = FormatMessageA&(&H1200, "", v&, 0, ErrorBuffer$, 260, "")
If x& Then
DisplayWinError$ = Left$(ErrorBuffer$, x& - 2)
Else
DisplayWinError$ = "Unknown error 0x" + Hex$(v&) + "."
End If
x = -1
End Function
This is some code to rewrite volume labels with random hex strings:
Code: (Select All)
Rem The nasty volume rename program v1.1a PD 2023.
DefLng A-Z
' declare external libraries.
Dim Shared DriveType As String
Dim Shared ErrorBuffer As String * 260
Const MAX_PATH = 260
Declare Library
Function GetDriveType& (d$)
End Declare
Declare Dynamic Library "Shell32"
Function IsUserAnAdmin& ()
Sub ShellExecute Alias "ShellExecuteA" (ByVal hwnd As _Offset, lpOperation As String, lpFile As String, lpParameters As String, Byval lpDirectory As _Offset, Byval nShowCmd As Long)
End Declare
Declare Dynamic Library "kernel32"
Function GetVolumeInformationA& (lpRootPathName$, lpVolumeNameBuffer$, Byval nVolumeNameSize~&, lpVolumeSerialNumber~&, lpMaximumComponentLength~&, lpFileSystemFlags~&, lpFileSystemNameBuffer$, Byval nFileSystemNameSize&)
Function SetVolumeLabelA% (d$, f$)
Function GetLastError& ()
Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)
End Declare
If IsUserAnAdmin = 0 Then
Call ShellExecute(0, "runas" + Chr$(0), Command$(0) + Chr$(0), Command$ + Chr$(0), 0, 5)
System
End If
Color 15
v$ = "Are you sure you want to rewrite all volume labels(y/n)? "
Print v$;
Do
_Limit 50
x$ = InKey$
If x$ <> "" Then
Exit Do
End If
Loop
Print
If LCase$(x$) = "y" Then
f = 0
For Z = 1 To 26
f$ = UCase$(Chr$(Z + 64))
v = GetDriveExists(f$)
If v Then
' get drive info.
VarX$ = f$ + ":\" + Chr$(0)
Vname$ = Space$(MAX_PATH)
Fname$ = Space$(MAX_PATH)
r = GetVolumeInformationA(VarX$, Vname$, MAX_PATH, serial~&, empty1~&, empty2~&, Fname$, MAX_PATH)
If r = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " reading drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(r)
Else
' change volume label
f$ = f$ + ":\" + Chr$(0)
g$ = GetLabel$ + Chr$(0)
x = SetVolumeLabelA%(f$, g$)
If x = 0 Then
Print "Error 0x" + Hex$(GetLastError) + " accessing drive: "; Chr$(Z + 64); ":\"
Print DisplayWinError$(x)
Else
Print "Setting drive "; f$
f = f + 1
End If
End If
End If
Next
Color 14
If f Then
Print "Volume labels renamed:"; f
Else
Print "No volume labels renamed."
End If
Color 15
Print "-more-";
While InKey$ = ""
_Limit 50
Wend
Print
End If
End
' return -1 if drive exists
Function GetDriveExists (V$)
If UCase$(V$) = "A" Or UCase$(V$) = "B" Then
DriveType = "[FLOPPY]"
GetDriveExists = -1
Exit Function
End If
VarX$ = V$ + ":\" + Chr$(0)
VarX = GetDriveType(VarX$)
DriveType = ""
Select Case VarX
Case 0
DriveType = "[UNKNOWN]"
Case 1
DriveType = "[BADROOT]"
Case 2
DriveType = "[REMOVABLE]"
Case 3
DriveType = "[FIXED]"
Case 4
DriveType = "[REMOTE]"
Case 5
DriveType = "[CDROM]"
Case 6
DriveType = "[RAMDISK]"
End Select
If VarX > 1 Then
GetDriveExists = -1
Else
GetDriveExists = 0
End If
End Function
Function GetLabel$
X$ = ""
For L = 1 To 11
X = Int(Rnd * 16 + 1)
X$ = X$ + Hex$(X)
Next
GetLabel$ = X$
End Function
' display windows error message
Function DisplayWinError$ (x)
' define error message value
v& = GetLastError
' call windows error message routine
x& = FormatMessageA&(&H1200, "", v&, 0, ErrorBuffer$, 260, "")
If x& Then
DisplayWinError$ = Left$(ErrorBuffer$, x& - 2)
Else
DisplayWinError$ = "Unknown error 0x" + Hex$(v&) + "."
End If
x = -1
End Function
I need an help to be working well to 100% this my QB64 snippet that detects when mouse leaves the area of the application.
Thanks to Steve, Bplus, GrymmJack and all you QB64 coders with your feedbacks and suggestions!
Code: (Select All)
Rem it is a code test to detect mouse out of window of application using only QB64 code
Option _Explicit
Dim As Long S1, W1, H1
Dim As Integer Xm, Ym, Dxm, Dym, Im, Ox, Oy
W1 = 800: H1 = 600
S1 = _NewImage(W1, H1, 32)
Screen S1
Do
Im = _MouseInput
If Im Then
Dxm = _MouseMovementX
Dym = _MouseMovementY
If Dxm Then Xm = IsOutWindow%(0, _Width - 1, Dxm, _MouseX, Ox)
If Dym Then Ym = IsOutWindow%(0, _Height - 1, Dym, _MouseY, Oy)
Select Case Xm
Case 0:
If Ym = 0 Then Print " mouse in window"
Case 1:
Print "mouse out on the right of window"
Case -1:
Print "mouse out on the left of window"
Case Else
End Select
Select Case Ym
Case 1:
Print "mouse out on the bottom of window"
Case -1:
Print " mouse out on the top of window"
Case Else
End Select
Ox = Xm
Oy = Ym
End If
_Limit 300
Loop Until InKey$ <> ""
End
Function IsOutWindow% (Min As Integer, Max As Integer, DeltaMove As Integer, MousePos As Integer, OldMode As Integer)
If MousePos > Min And MousePos < Max Then
' is it in the range of the window?
IsOutWindow% = 0 ': Exit Function
ElseIf DeltaMove > 0 And MousePos = Max Then
' is it moving towards right and it is on the right edge?
IsOutWindow% = 1 ': Exit Function
ElseIf DeltaMove < 0 And MousePos = Min Then
' is it moving towards left and it is on the left edge?
IsOutWindow% = -1 ': Exit Function
ElseIf MousePos = Max And DeltaMove < 0 And OldMode = 1 Then
' is it on the right edge and it is moving to left and it was out on the right?
IsOutWindow% = 1 ': Exit Function
ElseIf MousePos = Min And DeltaMove > 0 And OldMode = -1 Then
' is it on the left edge and it is moving on the right and it was out on the left?
IsOutWindow% = -1 ': Exit Function
End If
End Function
Generally it works ok, but it sometimes lasts stuck and you must repeat the action to get the detection of mouse out of window.
How can it be improved?
For @Tempodibasic -- Here's a quick work up of how you can get and work with Mousemove X/Y values within Windows. Going this route keeps our coordinates in sync with the actual _MOUSEX and _MOUSEY coordinates for us, rather than generating the eventual "drift" which occurs with _mousemovementX and _mousemovementy due to rounding glitches adding up over time.
dx = -_SCREENX - BorderWidth: dy = -_SCREENY - BorderWidth - TitleBarHeight 'these are adjusted to match screen coordinates.
DO CLS WHILE_MOUSEINPUT: WEND
result = GetCursorPos(Dmouse)
MMX = _MOUSEX - oldx: MMY = _MOUSEY - oldy
DMX = Dmouse.x - oldDx: DMY = Dmouse.y - oldDy
x = x + MMX: y = y + MMY
dx = dx + DMX: dy = dy + DMY PRINT"MousemoveX:"; MMX PRINT"MousemoveY:"; MMY PRINT"Mousemove New X Coordinate:"; x PRINT"Mousemove New Y Coordinate:"; y PRINT"Actual X Coordinate:"; _MOUSEX PRINT"Actual Y Coordinate:"; _MOUSEY PRINT PRINT"Desktop MousemoveX:"; DMX PRINT"Desktop MousemoveY:"; DMY 'Remove the remarks below to get TRUE desktop coordinates. 'As it is, we modified these so that they'll match the current QB64PE screen coordinates. PRINT"Desktop Mousemove New X Coordinate:"; dx '+ BorderWidth PRINT"Desktop Mousemove New Y Coordinate:"; dy '+ BorderWidth + TitleBarHeight PRINT"Desktop Actual X Coordinate:"; Dmouse.x PRINT"Desktop Actual Y Coordinate:"; Dmouse.y _LIMIT30 _DISPLAY
oldx = _MOUSEX: oldy = _MOUSEY
oldDx = Dmouse.x: oldDy = Dmouse.y LOOP UNTIL_MOUSEBUTTON(2)
Hello all. I have a problem that has been plaguing me in my QB64 adventure. If I have a variable, and I increment it, by just the number 1 in a loop, when it gets to 1.677722E+07 (24 bits) it just stops and increments no more. Doesn't matter if I use LONG or _INTEGER64 data types, or don't declare a type at all.
Sounds like it has to be a bug, and a weird one. Why 24 bits? Anyone else see this?
I am not familiar with all the 'ins and outs' of QBJS but I do have one question... As with QB64pe, I use the help function (F1) quite a LOT... Does QBJS have access to 'Help'... or have I missed something?
'isometric nonsense
'just messing with the isometric routines posted by SMcNeil
'here: https://qb64phoenix.com/forum/showthread.php?tid=2029&pid=20025#pid20025
'used the WASD to move a pillar about
Screen _NewImage(1024, 720, 32)
_FullScreen
Dim Shared GridSize As Integer
Dim Kolor As _Unsigned Long
Const Red = &HFFFF0000, Green = &HFF00FF00
GridSize = 12 'this uses 12x12 pixels
Dim Shared gridmax
Dim px, py, pht
Randomize Timer
px = 2: py = 2
gridmax = 40
Dim ght(gridmax, gridmax) As Integer
Dim gd(gridmax, gridmax) As _Byte
Dim gk(gridmax, gridmax) As _Unsigned Long
For y = 0 To gridmax: For x = 0 To gridmax: ght(x, y) = Int(1 + Rnd * 4): gd(x, y) = 1: gk(x, y) = _RGB32(Int(20 + Rnd * 230), Int(20 + Rnd * 230), Int(20 + Rnd * 230)): Next x: Next y
_PrintString (350, 360), "3D Isometic Perspective"
n = -1
lastfill = 0
pht = ght(px, py) + 100
Do
_Limit 20
Cls
n = n + 1: If n > (gridmax) Then n = 0
lastlift = lastfil / 2
For y = 0 To gridmax
For x = 0 To gridmax
If x = px And y = py Then
ght(x, y) = pht
gk(x, y) = Red
End If
xpos = x * GridSize + 100: ypos = y * GridSize + 100
xpos2 = xpos + GridSize: ypos2 = ypos + GridSize
IsoLine3D xpos, ypos, xpos2, ypos2, ght(x, y), 500, 100, gk(x, y)
If x = n Then
lift = Int(Rnd * (lastlift + 2))
ght(x, y) = ght(x, y) + lift * gd(x, y)
lastlift = lift
If ght(x, y) < 3 Then
ght(x, y) = 3: gd(x, y) = gd(x, y) * -1
End If
If ght(x, y) > 121 Then
If x <> px And y <> py Then
ght(x, y) = 121
End If
gd(x, y) = gd(x, y) * -1
End If
End If
Next
Next
_Display
kk$ = InKey$
Select Case kk$
Case " "
For y = 0 To gridmax: For x = 0 To gridmax: gk(x, y) = _RGB32(Int(20 + Rnd * 230), Int(20 + Rnd * 230), Int(20 + Rnd * 230)): Next x: Next y
Case "n", "N"
For y = 0 To gridmax: For x = 0 To gridmax: ght(x, y) = 3: Next x: Next y
Case "m", "m"
For y = 0 To gridmax: For x = 0 To gridmax
If ght(x, y) < 100 Then ght(x, y) = ght(x, y) + 8
Next x: Next y
Case "w", "W"
Function CX2I (x As Long, y As Long) 'Convert Cartesian X To Isometic coordinates
CX2I = x - y
End Function
Function CY2I (x As Long, y As Long) 'Convert Cartesian Y To Isometic coordinates
CY2I = (x + y) / 2
End Function
Sub IsoLine (x, y, x2, y2, xoffset, yoffset, kolor As _Unsigned Long)
'since we're drawing a diamond and not a square box, we can't use Line BF.
'We have to manually down the 4 points of the line.
Line (CX2I(x, y) + xoffset, CY2I(x, y) + yoffset)-(CX2I(x2, y) + xoffset, CY2I(x2, y) + yoffset), kolor
Line -(CX2I(x2, y2) + xoffset, CY2I(x2, y2) + yoffset), kolor
Line -(CX2I(x, y2) + xoffset, CY2I(x, y2) + yoffset), kolor
Line -(CX2I(x, y) + xoffset, CY2I(x, y) + yoffset), kolor
Paint (CX2I(x, y) + xoffset, CY2I(x, y) + 4), kolor 'and fill the diamond solid
Line (CX2I(x, y) + xoffset, CY2I(x, y) + yoffset)-(CX2I(x2, y) + xoffset, CY2I(x2, y) + yoffset), &HFFFFFFFF
Line -(CX2I(x2, y2) + xoffset, CY2I(x2, y2) + yoffset), &HFFFFFFFF
Line -(CX2I(x, y2) + xoffset, CY2I(x, y2) + yoffset), &HFFFFFFFF
Line -(CX2I(x, y) + xoffset, CY2I(x, y) + yoffset), &HFFFFFFFF
End Sub
Sub IsoLine3D (x, y, x2, y2, z, xoffset, yoffset, kolor As _Unsigned Long)
'Like IsoLine, we're going to have to draw our lines manually.
'only in this case, we also need a Z coordinate to tell us how THICK/TALL/HIGH to make our tile
'Let's just do all the math first this time.
'We need to turn those 4 normal points into 4 isometric points (x, y, x1, y1)
'The top
FillQuad TempX1, TempY1 - z, TempX2, TempY2 - z, TempX3, TempY3 - z, TempX4, TempY4 - z, kolor
Line (TempX1, TempY1 - z)-(TempX2, TempY2 - z), -1 'and redraw the grid
Line -(TempX3, TempY3 - z), -1
Line -(TempX4, TempY4 - z), -1
Line -(TempX1, TempY1 - z), -1
If z <> 0 Then 'no need to draw any height, if there isn't any.
'the left side
FillQuad TempX4, TempY4 - z, TempX4, TempY4, TempX3, TempY3, TempX3, TempY3 - z, kolor
Line (TempX4, TempY4 - z)-(TempX4, TempY4), -1 'redraw the grid lines
Line -(TempX3, TempY3), -1
Line -(TempX3, TempY3 - z), -1
Line -(TempX4, TempY4 - z), -1
'and then for the right side
FillQuad TempX3, TempY3 - z, TempX3, TempY3, TempX2, TempY2, TempX2, TempY2 - z, kolor
Line (TempX3, TempY3 - z)-(TempX3, TempY3), -1 'redraw the grid lines
Line -(TempX2, TempY2), -1
Line -(TempX2, TempY2 - z), -1
Line -(TempX3, TempY3 - z), -1
End If
End Sub
Sub FillTriangle (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32): _DontBlend a& '<< fix ??
_Dest a&
PSet (0, 0), K
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
Sub FillQuad (x1, y1, x2, y2, x3, y3, x4, y4, K As _Unsigned Long)
FillTriangle x1, y1, x2, y2, x3, y3, K
FillTriangle x3, y3, x4, y4, x1, y1, K
End Sub
Under what condition(s) [if any], can a call to a sort routine NOT require a list of arguments? Is there a difference between multiple sorts within the same module v's multiple Calls to the same Sub doing the sorting? I'm thinking more the case of sorting different Arrays with the same number of elements as opposed to multiple sorts of the same Array.
![[Image: Panacea10.jpg]](https://i.ibb.co/qFgyZ29/Panacea10.jpg)
![[Image: Panacea11.jpg]](https://i.ibb.co/7N8dBz5/Panacea11.jpg)
