| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 764
|
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
|
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
|
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
|
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,262
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 316
|
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
|
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
|
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
|
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155
|
|
|
| Planetary System Animation |
|
Posted by: James D Jarvis - 10-10-2022, 03:49 PM - Forum: Programs
- Replies (11)
|
 |
A simple program that randomly generates a planetary system showing the main star, some planets, and moons. There's no physics here and sizes are exaggerated so there is something to see.
EDIT: corrected the value to generate nump so it's the same in both locations in the program.
Code: (Select All) 'planetary system animation
'by James D, Jarvis 10/10/2022
'
' a simple planetary system animation generator, planets and moons orbiting a star
' <esc> to exit
' press "n" for a new system
'feel free to modify for your own use as you wish
Screen _NewImage(1200, 800, 32)
_FullScreen _SquarePixels
Randomize Timer
_Define K As _UNSIGNED LONG
stars& = _NewImage(1200, 800, 32)
_Dest stars&
For s = 1 To 1200
PSet (Rnd * _Width, Rnd * _Height), _RGB32(240 + Rnd * 15, 240 + Rnd * 15, 240 + Rnd * 15)
Next s
_Dest 0
Type planet_type
orbit As Double
size As Double
kp As _Unsigned Long
rate As Double
ppos As Double
End Type
Dim Shared sunx, suny, mooncount(20)
sunx = _Width / 2: suny = _Height / 2: sunr = 10 + Int(Rnd * 40): Ksun = _RGB32(250, 200 + sunr, 0)
Dim Shared planet(20) As planet_type
Dim Shared moon(20, 12) As planet_type
Nump = Int(1 + Rnd * 20)
For p = 1 To Nump
planet(p).orbit = p * (sunr * 1.5) + Rnd * 10
planet(p).size = 1 + Int(Rnd * 8)
planet(p).kp = _RGB32(Int(5 + Rnd * 250), Int(5 + Rnd * 250), Int(5 + Rnd * 250))
planet(p).rate = (5 / p) / (50 / Sqr(sunr))
planet(p).ppos = Int(Rnd * 360)
If p > 1 Then
nm = (Int(Rnd * (p + 3)))
If nm > 12 Then nm = Int(nm / 2)
mooncount(p) = nm
For m = 1 To mooncount(p)
moon(p, m).orbit = m * (planet(p).size * 1.5) + Rnd * 10
moon(p, m).size = .5 + Int(Rnd * (planet(p).size / 3))
moon(p, m).kp = _RGB32(Int(200 + Rnd * 53), Int(200 + Rnd * 53), Int(200 + Rnd * 53))
moon(p, m).rate = ((5 / p) / _Pi) * (1 + Rnd * 3)
moon(p, m).ppos = Int(Rnd * 360)
Next m
End If
Next p
Do
_Limit 60
Cls
_PutImage , stars&, 0
circleBF sunx, suny, sunr, Ksun
For n = 1 To Nump
drawplanet n
Next
_Display
kk$ = InKey$
If kk$ = "n" Then
stars& = _NewImage(800, 800, 32)
_Dest stars&
For s = 1 To 1200
PSet (Rnd * _Width, Rnd * _Height), _RGB32(240 + Rnd * 15, 240 + Rnd * 15, 240 + Rnd * 15)
Next s
_Dest 0
sunr = 10 + Int(Rnd * 40): Ksun = _RGB32(100 + sunr * 2 + Rnd * 50, sunr * 4 + Rnd * 50, 0)
Nump = Int(1 + Rnd * 20)
For p = 1 To Nump
planet(p).orbit = p * (sunr * 1.5) + Rnd * 10
planet(p).size = 1 + Int(Rnd * 8)
planet(p).kp = _RGB32(Int(5 + Rnd * 250), Int(5 + Rnd * 250), Int(5 + Rnd * 250))
planet(p).rate = (5 / p) / (50 / Sqr(sunr))
planet(p).ppos = Int(Rnd * 360)
If p > 1 Then
nm = (Int(Rnd * (p + 3)))
If nm > 12 Then nm = Int(nm / 2)
mooncount(p) = nm
For m = 1 To mooncount(p)
moon(p, m).orbit = (planet(p).size * 1.5) + m * planet(p).size
moon(p, m).size = .5 + Int(Rnd * (planet(p).size / 3))
moon(p, m).kp = _RGB32(Int(200 + Rnd * 53), Int(200 + Rnd * 53), Int(200 + Rnd * 53))
moon(p, m).rate = ((5 / p) / _Pi) * (1 + Rnd * 3)
moon(p, m).ppos = Int(Rnd * 360)
Next m
End If
Next p
End If
Loop Until kk$ = Chr$(27)
_FreeImage stars&
Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
rsqrd = r * r
y = -r
While y <= r
x = Sqr(rsqrd - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
y = y + 1
Wend
End Sub
Sub drawplanet (p)
x = planet(p).orbit * Sin(0.01745329 * planet(p).ppos)
y = planet(p).orbit * Cos(0.01745329 * planet(p).ppos)
x2 = (planet(p).orbit - planet(p).size / 2) * Sin(0.01745329 * planet(p).ppos)
y2 = (planet(p).orbit - planet(p).size / 2) * Cos(0.01745329 * planet(p).ppos)
x3 = (planet(p).orbit - planet(p).size / 3) * Sin(0.01745329 * planet(p).ppos)
y3 = (planet(p).orbit - planet(p).size / 3) * Cos(0.01745329 * planet(p).ppos)
pr = _Red(planet(p).kp)
pg = _Green(planet(p).kp)
pb = _Blue(planet(p).kp)
planet(p).ppos = planet(p).ppos + planet(p).rate
circleBF sunx + x, suny + y, planet(p).size, planet(p).kp
circleBF sunx + x2, suny + y2, planet(p).size / 2.5, _RGB32(pr * 1.1, pg * 1.1, pb * 1.05)
circleBF sunx + x3, suny + y3, planet(p).size / 4, _RGB32(pr * 1.2, pg * 1.2, pb * 1.1)
If mooncount(p) > 0 Then
For m = 1 To mooncount(p)
mx = moon(p, m).orbit * Sin(0.01745329 * moon(p, m).ppos)
my = moon(p, m).orbit * Cos(0.01745329 * moon(p, m).ppos)
circleBF sunx + x + mx, suny + y + my, moon(p, m).size, moon(p, m).kp
moon(p, m).ppos = moon(p, m).ppos + moon(p, m).rate
Next m
End If
End Sub
|
|
|
| Help with F1 function for Help |
|
Posted by: PhilOfPerth - 10-07-2022, 03:24 AM - Forum: Help Me!
- Replies (22)
|
 |
There seems to be a bit of discrepancy in the f1 Help function.
If I use the Tab function in my programme, eg Tab(10), then select the keyword Tab and press f1 for Help, it gets ignored, but if I insert a space between Tab and ( - which the IDE removes later- I get the explanation as expected.
But with other non-spaced functions, like left$( (which are also ignored until a space is inserted), if I insert a space I'm offered a choice of explanation for the $ sign or for String, neither of which is what I need. This also happens with Mid$( and Left$( and others.
I know, I can refer to Wiki, but the f1 help is more convenient, and if this is offered it should be consistent.
|
|
|
|
| Zoom_Circle |
|
Posted by: James D Jarvis - 10-06-2022, 03:21 AM - Forum: Programs
- Replies (4)
|
|
Zoom_Circle. A really simple program to get the angle on using angular headings control simple sprite movement.
Code: (Select All) 'Zoom Circle
'
'low end control example with angular navigation, dubious physics, and screenwrap
' w - accelerate
' s - decelerate
' a - turn to port
' d- tunr to starboard
'<esc> - end program
'
Screen _NewImage(800, 500, 32)
Dim Shared klr As _Unsigned Long
ppx = 400
ppy = 250
hdg = 90
hc = 0
mr = 0
fuel = 100000
tx = ppx + 3.5 * Sin(0.01745329 * hdg)
ty = ppy + 3.5 * Cos(0.01745329 * hdg)
Do
Cls
_Limit 30
Circle (ppx, ppy), 4, _RGB32(250, 250, 100) 'the zoom_circle saucer
Circle (tx, ty), 2, _RGB32(255, 255, 255) 'this nubbin is to show where the cricle is heading
ppx = ppx + mr * Sin(0.01745329 * hdg)
ppy = ppy + mr * Cos(0.01745329 * hdg)
kk$ = InKey$
Locate 1, 1: Print "Fuel : "; Int(fuel)
Locate 1, 20: Print "Velocity :"; Int(mr * 200)
_Display
Select Case kk$
Case "w"
If fuel > 0 Then
mr = mr + 0.05 * (100000 / fuel)
Circle (rrx, rry), 2, _RGB32(255, 255, 255)
fuel = fuel - 1
End If
Case "s"
If fuel > 0 Then
fuel = fuel - Sqr(mr / 0.05)
mr = mr - 0.05
If mr < 0 Then mr = 0
End If
Case "a"
If fuel > 0 Then
fuel = fuel - Sqr(Sqr(mr / 0.05))
hc = hc + 2
mr = mr * 0.995
End If
Case "d"
If fuel > 0 Then
fuel = fuel - Sqr(Sqr(mr / 0.05))
hc = hc - 2
mr = mr * .995
End If
End Select
hdg = hdg + hc
hc = hc * .75
If ppx < -4 Then ppx = 800
If ppx > 804 Then ppx = 0
If ppy < -4 Then ppy = 500
If ppy > 504 Then ppy = 0
tx = ppx + 3.5 * Sin(0.01745329 * hdg)
ty = ppy + 3.5 * Cos(0.01745329 * hdg)
Loop Until kk$ = Chr$(27)
|
|
|
|
| NEW URL Downloader (WinHTTP) |
|
Posted by: SpriggsySpriggs - 10-05-2022, 07:52 PM - Forum: Spriggsy
- Replies (3)
|
 |
I have made a new version of my URL downloader. This one uses the newer WinHTTP functions. It is based on the MSDN example Authentication in WinHTTP.
Like the other version, this starts up with a console window so you can easily paste your URL.
Code: (Select All) Option Explicit
$NoPrefix
Const WINHTTP_AUTH_TARGET_SERVER = &H00000000
Const WINHTTP_AUTH_TARGET_PROXY = &H00000001
Const WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0
Const WINHTTP_ACCESS_TYPE_NO_PROXY = 1
Const WINHTTP_ACCESS_TYPE_NAMED_PROXY = 3
Const WINHTTP_NO_PROXY_NAME = 0
Const WINHTTP_NO_PROXY_BYPASS = 0
Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_DEFAULT_HTTPS_PORT = 443
Const WINHTTP_NO_REFERER = 0
Const WINHTTP_DEFAULT_ACCEPT_TYPES = 0
Const WINHTTP_FLAG_SECURE = &H00800000
Const WINHTTP_NO_ADDITIONAL_HEADERS = 0
Const WINHTTP_NO_REQUEST_DATA = 0
Const WINHTTP_ERROR_BASE = 12000
Const ERROR_WINHTTP_RESEND_REQUEST = WINHTTP_ERROR_BASE + 32
Const WINHTTP_QUERY_STATUS_CODE = 19
Const WINHTTP_QUERY_FLAG_NUMBER = &H20000000
Const WINHTTP_QUERY_CONTENT_LENGTH = 5
'Const WINHTTP_QUERY_CONTENT_TYPE = 1
Const WINHTTP_QUERY_CUSTOM = 65535
Const KILOBYTE = 1024
Const MEGABYTE = KILOBYTE ^ 2
Const GIGABYTE = KILOBYTE ^ 3
Const TERABYTE = KILOBYTE ^ 4
Declare Dynamic Library "winhttp"
Function WinHttpOpen%& (pszAgentW As String, Byval dwAccessType As Unsigned Long, Byval pszProxyW As Offset, Byval pszProxyBypassW As Offset, Byval dwFlags As Unsigned Long)
Function WinHttpConnect%& (ByVal hSession As Offset, Byval pswzServerName As Offset, Byval nServerPort As Unsigned Integer, Byval dwReserved As Unsigned Long)
Function WinHttpOpenRequest%& (ByVal hConnect As Offset, pwszVerb As String, Byval pwszObjectName As Offset, Byval pwszVersion As Offset, Byval pwszReferer As Offset, Byval ppwszAcceptTypes As Offset, Byval dwFlags As Unsigned Long)
Function WinHttpSendRequest& (ByVal hRequest As Offset, Byval lpszHeaders As Offset, Byval dwHeadersLength As Unsigned Long, Byval lpOptional As Offset, Byval dwOptionalLength As Unsigned Long, Byval dwTotalLength As Unsigned Long, Byval dwContext As Unsigned Long)
Function WinHttpReceiveResponse& (ByVal hRequest As Offset, Byval lpReserved As Offset)
Function WinHttpQueryDataAvailable& (ByVal hRequest As Offset, Byval lpdwNumberOfBytesAvailable As Offset)
Function WinHttpReadData& (ByVal hRequest As Offset, Byval lpBuffer As Offset, Byval dwNumberOfBytesToRead As Unsigned Long, Byval lpdwNumberOfBytesRead As Offset)
Function WinHttpQueryHeaders& (ByVal hRequest As Offset, Byval dwInfoLevel As Unsigned Long, Byval pwszName As Offset, Byval lpBuffer As Offset, Byval lpdwBufferLength As Offset, Byval lpdwIndex As Offset)
Sub WinHttpQueryHeaders (ByVal hRequest As Offset, Byval dwInfoLevel As Unsigned Long, Byval pwszName As Offset, Byval lpBuffer As Offset, Byval lpdwBufferLength As Offset, Byval lpdwIndex As Offset)
Sub WinHttpCloseHandle (ByVal hInternet As Offset)
End Declare
Declare Library
Function GetLastError~& ()
End Declare
Declare Dynamic Library "shlwapi"
Function UrlUnescape& Alias "UrlUnescapeA" (ByVal pszUrl As Offset, Byval pszUnescaped As Offset, Byval pcchUnescaped As Offset, Byval dwFlags As Unsigned Long)
End Declare
Screen NewImage(480, 120, 32)
$ScreenHide
_ScreenHide
$Console
Dest Console
Title "WinHTTP URL Downloader"
ConsoleTitle "Enter Link"
Dim As String link
Do
Cls
Line Input "Link: ", link
Loop Until link <> ""
ScreenShow
Title Title$ + " - " + link
Console Off
Dest 0
WinHttpDownload link
Sub WinHttpDownload (url As String)
Dim As String server, path, ansipath
DivideURL url, server, path
ansipath = path
Dim As Long useSSL: useSSL = -1
server = ANSIToUnicode(server)
path = ANSIToUnicode(path)
Dim As Unsigned Long dwStatusCode, dwSupportedSchemes, dwFirstScheme, dwSelectedScheme, dwTarget, dwLastStatus, dwSize: dwSize = Len(dwSize)
Dim As Long bResults, bDone
Dim As Offset hSession, hConnect, hRequest
hSession = WinHttpOpen(ANSIToUnicode("Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/42.0.2311.135 Safari/537.36 Edge/12.246" + Chr$(0)), WINHTTP_ACCESS_TYPE_DEFAULT_PROXY, WINHTTP_NO_PROXY_NAME, WINHTTP_NO_PROXY_BYPASS, 0)
Dim As Unsigned Integer nPort
If useSSL Then nPort = INTERNET_DEFAULT_HTTPS_PORT Else nPort = INTERNET_DEFAULT_HTTP_PORT
If hSession Then hConnect = WinHttpConnect(hSession, Offset(server), nPort, 0)
If hConnect Then
If useSSL Then
hRequest = WinHttpOpenRequest(hConnect, ANSIToUnicode("GET" + Chr$(0)), Offset(path), 0, WINHTTP_NO_REFERER, WINHTTP_DEFAULT_ACCEPT_TYPES, WINHTTP_FLAG_SECURE)
Else
hRequest = WinHttpOpenRequest(hConnect, ANSIToUnicode("GET" + Chr$(0)), Offset(path), 0, WINHTTP_NO_REFERER, WINHTTP_DEFAULT_ACCEPT_TYPES, 0)
End If
End If
If hRequest = 0 Then bDone = -1
Dim As Single y: y = Timer
bResults = WinHttpSendRequest(hRequest, WINHTTP_NO_ADDITIONAL_HEADERS, 0, WINHTTP_NO_REQUEST_DATA, 0, 0, 0)
If bResults Then bResults = WinHttpReceiveResponse(hRequest, 0)
If bResults Then bResults = WinHttpQueryHeaders(hRequest, WINHTTP_QUERY_STATUS_CODE Or WINHTTP_QUERY_FLAG_NUMBER, 0, Offset(dwStatusCode), Offset(dwSize), 0)
If bResults Then
Select Case dwStatusCode
Case 200
Dim As Unsigned Long totalsize, lentotal: lentotal = Len(totalsize)
WinHttpQueryHeaders hRequest, WINHTTP_QUERY_CONTENT_LENGTH Or WINHTTP_QUERY_FLAG_NUMBER, 0, Offset(totalsize), Offset(lentotal), 0
Dim As String buffer, outstring
Dim As Unsigned Long bytesread, bytesavailable
If WinHttpQueryDataAvailable(hRequest, Offset(bytesavailable)) Then
Dim As Unsigned Long bytesout, bytesforrate
Dim As Long outfile: outfile = FreeFile
Dim As String filepath: filepath = ansipath
filepath = Mid$(filepath, InStrRev(filepath, "/") + 1)
If InStr(filepath, ".") Then filepath = Mid$(filepath, 1, InStrRev(filepath, ".") + 3)
Dim As String parsedfilepath: parsedfilepath = Space$(1024)
Dim As Unsigned Long requiredbytes: requiredbytes = Len(parsedfilepath)
Dim As String toparse: toparse = filepath + Chr$(0)
If UrlUnescape(Offset(toparse), Offset(parsedfilepath), Offset(requiredbytes), 0) = 0 Then
filepath = Mid$(parsedfilepath, 1, requiredbytes)
Open "B", outfile, filepath
Else
Open "B", outfile, filepath
End If
Do
If WinHttpQueryDataAvailable(hRequest, Offset(bytesavailable)) Then
buffer = Space$(bytesavailable)
If WinHttpReadData(hRequest, Offset(buffer), Len(buffer), Offset(bytesread)) Then
If bytesread > 0 Then
outstring = Mid$(buffer, 1, bytesread)
bytesout = bytesout + bytesread
bytesforrate = bytesforrate + bytesread
Put outfile, , outstring
End If
End If
End If
Cls
If totalsize > 0 Then
Select Case bytesout
Case Is < KILOBYTE
Print Using "#### B downloaded of "; bytesout;
Case Is < MEGABYTE And bytesout >= KILOBYTE
Print Using "####.## KB downloaded of "; bytesout / KILOBYTE;
Case Is < GIGABYTE And bytesout >= MEGABYTE
Print Using "####.## MB downloaded of "; bytesout / MEGABYTE;
Case Is < TERABYTE And bytesout >= GIGABYTE
Print Using "####.## GB downloaded of "; bytesout / GIGABYTE;
End Select
Select Case totalsize
Case Is < KILOBYTE
Print Using "#### B"; totalsize
Case Is < MEGABYTE And totalsize >= KILOBYTE
Print Using "####.## KB"; totalsize / KILOBYTE
Case Is < GIGABYTE And totalsize >= MEGABYTE
Print Using "####.## MB"; totalsize / MEGABYTE
Case Is < TERABYTE And totalsize >= GIGABYTE
Print Using "####.## GB"; totalsize / GIGABYTE
End Select
Print Using "###.##%"; bytesout / totalsize * 100
Else
Select Case bytesout
Case Is < KILOBYTE
Print Using "#### B downloaded"; bytesout
Case Is < MEGABYTE And bytesout >= KILOBYTE
Print Using "####.## KB downloaded"; bytesout / KILOBYTE
Case Is < GIGABYTE And bytesout >= MEGABYTE
Print Using "####.## MB downloaded"; bytesout / MEGABYTE
Case Is < TERABYTE And bytesout >= GIGABYTE
Print Using "####.## GB downloaded"; bytesout / GIGABYTE
End Select
End If
Dim As Single Rate
Dim As Integer x: x = Round(Timer - y)
If x = 1 Then
Rate = (bytesforrate / x)
bytesforrate = 0
y = Timer
End If
Select Case Rate
Case Is < KILOBYTE
Print Using "Rate: #### Bps"; Rate
Case Is < MEGABYTE And Rate >= KILOBYTE
Print Using "Rate: ####.## KBps"; Rate / KILOBYTE
Case Is < GIGABYTE And Rate >= MEGABYTE
Print Using "Rate: ####.## MBps"; Rate / MEGABYTE
Case Is < TERABYTE And Rate >= GIGABYTE
Print Using "Rate: ####.## GBps"; Rate / GIGABYTE
End Select
Display
Loop While bytesavailable > 0
End If
Close outfile
Print "The resource was successfully retrieved."
Print "Saved to "; filepath
bDone = -1
Exit Case
Case Else
Print "Error. Status code"; dwStatusCode; "returned"
bDone = -1
End Select
End If
dwLastStatus = dwStatusCode
If bResults = 0 Then
Dim As Unsigned Long dwLastError: dwLastError = GetLastError
Print "Error"; dwLastError; "has occurred"
End If
If hRequest Then WinHttpCloseHandle hRequest
If hConnect Then WinHttpCloseHandle hConnect
If hSession Then WinHttpCloseHandle hSession
End Sub
Sub DivideURL (url As String, server As String, path As String)
If InStr(url, "http:") Or InStr(url, "https:") Then
server = Mid$(url, InStr(url, "/") + 2)
If InStr(server, "/") Then
server = Mid$(server, 1, InStr(server, "/") - 1)
End If
Else
If InStr(url, "/") Then
server = Mid$(url, 1, InStr(url, "/") - 1)
End If
End If
path = Mid$(url, InStr(url, server) + Len(server))
End Sub
Declare CustomType Library
Function WideCharToMultiByte& (ByVal CodePage As _Unsigned Long, Byval dwFlags As _Unsigned Long, Byval lpWideCharStr As _Offset, Byval cchWideChar As Long, Byval lpMultiByteStr As _Offset, Byval cbMultiByte As Long, Byval lpDefaultChar As _Offset, Byval lpUsedDefaultChar As _Offset)
Function MultiByteToWideChar& (ByVal CodePage As _Unsigned Long, Byval dwFlags As _Unsigned Long, Byval lpMultiByteStr As _Offset, Byval cbMultiByte As Long, Byval lpWideCharStr As _Offset, Byval cchWideChar As Long)
End Declare
Function UnicodeToANSI$ (buffer As String)
Dim As String ansibuffer: ansibuffer = Space$(Len(buffer))
Dim As Long a: a = WideCharToMultiByte(437, 0, _Offset(buffer), Len(buffer), _Offset(ansibuffer), Len(ansibuffer), 0, 0)
UnicodeToANSI = Mid$(ansibuffer, 1, InStr(ansibuffer, Chr$(0)) - 1)
End Function
Sub UnicodeToANSI (buffer As String, __dest As String)
Dim As String ansibuffer: ansibuffer = Space$(Len(buffer))
Dim As Long a: a = WideCharToMultiByte(437, 0, _Offset(buffer), Len(buffer), _Offset(ansibuffer), Len(ansibuffer), 0, 0)
__dest = Mid$(ansibuffer, 1, InStr(ansibuffer, Chr$(0)) - 1)
End Sub
Function ANSIToUnicode$ (buffer As String)
Dim As String unicodebuffer: unicodebuffer = Space$(Len(buffer) * 2)
Dim As Long a: a = MultiByteToWideChar(65001, 0, _Offset(buffer), Len(buffer), _Offset(unicodebuffer), Len(unicodebuffer))
ANSIToUnicode = unicodebuffer
End Function
Sub ANSIToUnicode (buffer As String, __dest As String)
Dim As String unicodebuffer: unicodebuffer = Space$(Len(buffer) * 2)
Dim As Long a: a = MultiByteToWideChar(65001, 0, _Offset(buffer), Len(buffer), _Offset(unicodebuffer), Len(unicodebuffer))
__dest = unicodebuffer
End Sub
![[Image: image.png]](https://i.ibb.co/ZmZJGpK/image.png) ![[Image: image.png]](https://i.ibb.co/f087LHG/image.png) ![[Image: image.png]](https://i.ibb.co/c6h8LmV/image.png)
As always, only 64 bit was tested and only 64 bit will be supported.
|
|
|
|
| Request: Suggestion for IDE |
|
Posted by: TerryRitchie - 10-05-2022, 05:42 PM - Forum: General Discussion
- Replies (18)
|
 |
This may sound like a silly suggestion but it would be nice if the mouse pointer disappeared after a few seconds of inactivity. I can't count the number of times, just today, I've had to move the mouse pointer out of the way because it was blocking the code exactly where I was typing.
Any mouse movement would then again bring the mouse pointer back into view.
I know this sounds like a simple request but I've taken a peek from time to time at the QB64 source code. Those who maintain that code are saints in my view. If it's something fairly easy to add could a future revision include this? I understand if this would be placed low on the priority list or not even considered however.
Terry
|
|
|
|
| In the spirit of Terry's Tutorials - GUARDIAN Alien Space Ship Game |
|
Posted by: Pete - 10-04-2022, 08:29 PM - Forum: Works in Progress
- Replies (24)
|
 |
When I build a program, I do so by making subs that can often act independently. It's a very easy way to join things together for bigger project. It also makes debugging a whole lot easier.
So I thought, since Terry provides excellent tutorials for newbies to fast track coding, I would join in the spirit of that perspective and put up some little project which shows step-wise development.
Alien Space Ship is an ASCII -<>- that, for starters, that flies randomly throughout the screen. The code is adaptable to various screen sizes. I'll start with a single ship for now. I'll show how to make a married ship, later.
Stage 1)
Code: (Select All) DIM SHARED top, bottom, left, right
a = 120: b = 42
WIDTH a, b
_SCREENMOVE 0, 0
top = 3: bottom = _HEIGHT: left = 0: right = _WIDTH
msg$ = "Alien space ship movement demo."
LOCATE 1, (right - left) \ 2 - LEN(msg$) \ 2
PRINT msg$;
LOCATE 1, 2: PRINT STRING$(_WIDTH, "_");
DO
_LIMIT 30
alien_move
LOOP
SUB alien_move:
STATIC a_y, a_x, olda_y, olda_x, alien$, inertia, ran, ran_y, ran_x, oldran, z5
IF ABS(z5 - TIMER) > .1 THEN ' Time delay.
y_restore = CSRLIN: x_restore = POS(0) ' Restore column and row upon exit.
IF alien$ = "" THEN alien$ = "-<>-"
IF olda_y <> 0 AND olda_x <> 0 THEN
LOCATE olda_y, olda_x: PRINT SPACE$(LEN(alien$));
ELSE
a_y = (bottom - top) \ 2: a_x = (right - left) \ 2 ' Center sreen.
END IF
IF inertia = 0 THEN
inertia = INT(RND * (bottom - top) / 2) + 1 ' How many moves to go in any one direction.
ran = INT(RND * 8) + 1 ' Choose 1 of 8 possible directions.
IF ran = oldran THEN LOCATE y_restore, x_restore: EXIT SUB ' Just hover if direction was not changed.
SELECT CASE ran ' Get changes in column and row coordinates.
CASE 1: ran_y = -1: ran_x = 0
CASE 2: ran_y = -1: ran_x = 1
CASE 3: ran_y = 0: ran_x = 1
CASE 4: ran_y = 1: ran_x = 1
CASE 5: ran_y = 1: ran_x = 0
CASE 6: ran_y = 1: ran_x = -1
CASE 7: ran_y = 0: ran_x = -1
CASE 8: ran_y = -1: ran_x = -1
END SELECT
oldran = ran ' Remember last direction.
ELSE
inertia = inertia - 1 ' Count down the number of moves in any one direction. When zero, switch direction.
END IF
a_y = a_y + ran_y: a_x = a_x + ran_x * 2 ' Next move coordinates. I use * 2 for horizontal movement to match the 16x8 pixel height over width factor.
IF a_y < top OR a_y > bottom OR a_x <= left OR a_x + LEN(alien$) > right THEN
olda_x = 0: olda_y = 0: inertia = 0: oldran = 0 ' Out of bounds and off the screen.
ELSE
LOCATE a_y, a_x: PRINT alien$; ' Move alien ship.
olda_y = a_y: olda_x = a_x ' Remember these coordinates to erase ship on next loop.
END IF
z5 = TIMER
LOCATE y_restore, x_restore ' Restore entry column and row positions.
END IF
END SUB
The next stage will demonstrate a way to start a ship on the screen from the left or right side, determined by initial right or left direction, at a somewhat random vertical starting point. Hey, if you develop a shooter game, it's not much of a challenge if you know in advance where the enemy vessel will appear.
Pete out.
|
|
|
|
| Fishing anyone? |
|
Posted by: bplus - 10-04-2022, 01:05 AM - Forum: Programs
- Replies (10)
|
 |
Look what I found, anyone up for some fishing?
Code: (Select All) Option _Explicit
_Title " Fish: press m for more, l for less" 'b+ 2021-12-03
Const sw = 1024, sh = 700, LHead$ = "<*", LBody$ = ")", LTail$ = "<{", RHead$ = "*>", RBody$ = "(", RTail$ = "}<"
Type fish
As Integer LFish, X, Y, DX
As String fish
As _Unsigned Long Colr
End Type
Screen _NewImage(sw, sh, 32)
_ScreenMove 180, 40
_FullScreen ' <<<<<<<<<<<<<<< goto full screen once you know instructions for more and less fish
Color _RGB32(220), _RGB32(0, 0, 60)
Cls
_PrintMode _KeepBackground
Dim As Integer i, nFish
Dim k$
nFish = 20
restart:
ReDim Shared school(1 To nFish) As fish, kelp(sw, sh) As _Unsigned Long
growKelp
For i = 1 To nFish
NewFish i, -1
Next
Do
Cls
k$ = InKey$
If k$ = "m" Then ' more fish
nFish = nFish * 2
If nFish > 300 Then Beep: nFish = 300
GoTo restart
End If
If k$ = "l" Then ' less fish
nFish = nFish / 2
If nFish < 4 Then Beep: nFish = 4
GoTo restart
End If
For i = 1 To nFish ' draw fish behind kelp
If _Red32(school(i).Colr) < 160 Then
Color school(i).Colr
_PrintString (school(i).X, school(i).Y), school(i).fish 'draw fish
school(i).X = school(i).X + school(i).DX
If school(i).LFish Then
If school(i).X + Len(school(i).fish) * 8 < 0 Then NewFish i, 0
Else
If school(i).X - Len(school(i).fish) * 8 > _Width Then NewFish i, 0
End If
End If
Next
showKelp
For i = 1 To nFish ' draw fish in from of kelp
If _Red32(school(i).Colr) >= 160 Then
Color school(i).Colr
_PrintString (school(i).X, school(i).Y), school(i).fish 'draw fish
school(i).X = school(i).X + school(i).DX
If school(i).LFish Then
If school(i).X + Len(school(i).fish) * 8 < 0 Then NewFish i, 0
Else
If school(i).X - Len(school(i).fish) * 8 > _Width Then NewFish i, 0
End If
End If
Next
_Display
_Limit 10
Loop Until _KeyDown(27)
Sub NewFish (i, initTF)
Dim gray
gray = Rnd * 200 + 55
school(i).Colr = _RGB32(gray) ' color
If Rnd > .5 Then
school(i).LFish = -1
school(i).fish = LHead$ + String$(Int(Rnd * 5) + -2 * (gray > 160) + 1, LBody$) + LTail$
Else
school(i).LFish = 0
school(i).fish = RTail$ + String$(Int(Rnd * 5) + -2 * (gray > 160) + 1, RBody$) + RHead$
End If
If initTF Then
school(i).X = _Width * Rnd
Else
If school(i).LFish Then school(i).X = _Width + Rnd * 35 Else school(i).X = -35 * Rnd - Len(school(i).fish) * 8
End If
If gray > 160 Then
If school(i).LFish Then school(i).DX = -18 * Rnd - 3 Else school(i).DX = 18 * Rnd + 3
Else
If school(i).LFish Then school(i).DX = -6 * Rnd - 1 Else school(i).DX = 6 * Rnd + 1
End If
school(i).Y = _Height * Rnd
End Sub
Sub growKelp
Dim kelps, x, y, r
ReDim kelp(sw, sh) As _Unsigned Long
kelps = Int(Rnd * 20) + 20
For x = 1 To kelps
kelp(Int(Rnd * sw / 8), (sh - 16) / 16) = _RGB32(0, Rnd * 128, 0)
Next
For y = sh / 16 To 0 Step -1
For x = 0 To sw / 8
If kelp(x, y + 1) Then
r = Int(Rnd * 23) + 1
Select Case r
Case 1, 2, 3, 18 '1 branch node
If x - 1 >= 0 Then kelp(x - 1, y) = kelp(x, y + 1)
Case 4, 5, 6, 7, 8, 9, 21 '1 branch node
kelp(x, y) = kelp(x, y + 1)
Case 10, 11, 12, 20 '1 branch node
If x + 1 <= sw Then kelp(x + 1, y) = kelp(x, y + 1)
Case 13, 14, 15, 16, 17, 19 '2 branch node
If x - 1 >= 0 Then kelp(x - 1, y) = kelp(x, y + 1)
If x + 1 <= sw Then kelp(x + 1, y) = kelp(x, y + 1)
End Select
End If
Next
Next
End Sub
Sub showKelp
Dim y, x
For y = 0 To sh / 16
For x = 0 To sw / 8
If kelp(x, y) Then
Color kelp(x, y)
_PrintString (x * 8, y * 16), Mid$("kelp", Int(Rnd * 4) + 1, 1)
End If
Next
Next
End Sub
Nice underwater effect with kelp.
|
|
|
|
| Steve's QB64 tutorials collection |
|
Posted by: vince - 10-04-2022, 12:39 AM - Forum: General Discussion
- Replies (3)
|
 |
does anyone have the complete collection of Steve style run-in-qb64-slideshow tutorials? I believe there was one on data types, floating point, and colors. Here's one I happened to have saved:
Code: (Select All) Screen _NewImage(640, 640, 32)
_Title "Number Types and Colors"
Print "Welcome to Steve's Qucik Lesson on Number Types and Colors."
Print
Print "The most important thing to keep in mind in this lesson is that we're going to be talking exclusively about 32-bit color values here. For all other screen modes, this lesson holds much less importance."
Print
Print "Press <ANY KEY> to begin!"
Sleep
Cls , 0
Print "First, let's talk about how SINGLE variable types work (or DON'T work), in regards to 32-bit colors."
Print
Print "Let's choose a nice color and use it to draw a box on the screen."
Print "How about we choose a BLUE box? _RGB32(0, 0, 255)"
Print
Line (50, 90)-(250, 250), _RGB32(0, 0, 255), BF
Locate 18, 1: Print "Looks like a nice BLUE box. Right?"
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "Now, let's store that BLUE value inside a SINGLE tyoe variable."
Print "BLUE = _RGB32(0, 0, 255)"
Print ""
Print "Once we've did that, let's draw the exact same box on the screen again with the variable."
BLUE = _RGB32(0, 0, 256)
Line (50, 90)-(250, 250), BLUE, BF
Locate 18, 1: Print "Looks like a nice BLUE box. Right?"
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "What do you guys mean, 'What box?'??"
Print "Do you mean to tell me you nice folks DIDN'T see a pretty BLUE box on the last screen??"
Print
Print
Print "Just what the hell happened to it?!!"
Print
Print
Print "For the answer to that, let's print out two values to the screen:"
Print "BLUE = "; BLUE
Print "_RGB32(0, 0, 255) = "; _RGB32(0, 0, 255)
Print
Print "At first glance, those APPEAR to be the same numbers, but let's expand the scientific notation fully:"
Blue&& = BLUE
Print "BLUE = "; Blue&&
Print "_RGB32(0, 0, 255) = "; _RGB32(0, 0, 255)
Print
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "HOLY COW, BATMAN!! Was those two numbers DIFFERENT?!!"
Print "BLUE = "; Blue&&; "vs"; _RGB32(0, 0, 255)
Print
Print "Well... They're only a LITTLE different... Right?"
Print "I mean, how bad can one little number difference be? Right??"
Print
Print "For the answer to that, let's look at the HEX values of those numbers:"
Print "BLUE = "; Hex$(Blue&&)
Print "_RGB32(0, 0, 255) - "; Hex$(_RGB32(0, 0, 255))
Print
Print "And to help understand what we're seeing in HEX, break those values down into groups of 2 in your mind."
Print "(I'm too lazy to do it for you..)"
Print "The first two values are ALPHA, followed by RED, followed by GREEN, followed by BLUE."
Print
Print "So BLUE = FF alpha, 00 red 01 green, 00 blue"
Print "_RGB32(0, 0, 0) = FF alpha, 00 red, 00 green, FF blue"
Print
Print "And keep in mine that FF is HEX for the decimal value of 255."
Print
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "Since SINGLE values lose precision after numbers get so large, our variable BLUE"
Print "has to round to the nearest scientific notation point and try for the closest"
Print "possible match."
Print
Print "And even though "; Blue&&; " is only one number off from "; _RGB32(0, 0, 255); ","
Print "that number still greatly changes the color value."
Print
Print "It changes it from FF 00 00 FF (255 alpha, 0 red, 0 green, 255 blue) to"
Print "FF 00 01 00 (255 alpha, 0 red, 1 green, 0 blue)."
Print
Print "Our BLUE has become a GREEN, simply by using a SINGLE variable type!!"
Print "(And, it's such a low shade green, my poor eyes can't make it out at all."
Print "To me, the damn 'green box' was just as black as my black screen."
Print "I didn't see it at all!)"
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "So, at this point, I think it should be obvious WHY we don't want to store"
Print "color values inside SINGLE variables."
Print
Print "But what about using a normal LONG to hold the values??"
Print
Print "Let's look and see!"
Print
Print "For this, let's draw our box again:"
Line (50, 150)-(250, 250), _RGB32(0, 0, 255), BF
Locate 18, 1: Print "Looks like a nice BLUE box. Right?"
Print
Print "But let's get the POINT value from that box, and store it in a LONG variable."
BLUE& = Point(100, 200)
Print "BLUE& = "; BLUE&
p&& = Point(100, 200)
Print "POINT(100, 200) = "; Point(100, 200)
Print
Print
Print "Again, we're looking at two numbers that don't match!"
Print
Print "FOR THE LOVE OF GOD, WHYYYY??!!!!"
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print BLUE&; "<>"; p&&
Print
Print "Why are those two numbers so different??"
Print
Print "For that answer, let's look at their HEX values again:"
Print "BLUE& = "; Hex$(BLUE&)
Print "POINT(100, 200) = "; Hex$(p&&)
Print
Print "."
Print "..."
Print "......"
Print
Print "WHAT THE HEX?? Those two values are EXACTLY the same??"
Print
Print "They are. It's just that one of them is stored as a SIGNED LONG, while the other is an UNSIGNED LONG."
Print
Print "HEX wise, they're the same value..."
Print
Print "BUT, can you see where the two numbers might not match if we use them in an IF statement?"
Print
Print "IF "; BLUE&; "="; p&&; "THEN...."
Print
Print "Ummm... That might not work as intended!"
Print
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "Even thought the HEX values for "; BLUE&; "and"; p&&;
Print "are EXACTLY the same, the values themselves are quite different."
Print
Print "A LONG will, indeed, hold the proper value for a 32-bit color, as it stores"
Print "all four HEX values properly for us."
Print
Print "As long as our program uses NOTHING but LONG values, you'll never have a"
Print "problem with using LONG as a variable type..."
Print
Print "BUT...."
Print
Print "The moment you start to compare LONG values directly against POINT values,"
Print "your program is going to run into serious issues!"
Print
Print "Because at the end of the day,"; BLUE&; "is not the same as "; p&&
Print
Print
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "So, with all those examples, and all that said, let's answer"
Print "the most important question:"
Print
Print "'What TYPE works best for 32-bit colors??"
Print
Print
Print "DOUBLE, _FLOAT, _UNSIGNED LONG, _INTEGER64, _UNSIGNED _INTEGER64"
Print
Print "Of all the types which QB64 offers, only the above are TRULY viable"
Print "to hold a 32-bit color value."
Print
Print "Any type not listed above is going to be problematic at one time or"
Print "another for us!"
Print
Print "And of those suitable types, I personally prefer to keep integer values"
Print "as integers, so I recommend: _UNSIGNED LONG or _INTEGER64."
Print
Print
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "And WHY _UNSIGNED LONG??"
Print
Print "Simply because it's only 4 bytes of memory (the minimal we can possibly use for"
Print "32-bit color values), and it's what QB64 uses internally with POINT and such."
Print
Print
Print "So, if _UNSIGNED LONG works so well, WHY would I *ever* use _INTEGER64??"
Print
Print "Becauses sometimes I like to code command values into my colors."
Print "(Such as: NoColor = -1)"
Print
Print "_UNSIGNED LONG *only* holds the values for the colors themselves."
Print "EVERY number from 0 to FFFFFFFF is accounted for as part of our color spectrum."
Print
Print "If I need *special* or unique values for my program, I usually just use _INTEGER64s"
Print "for my variable types and then I can assign negative numbers for those unique values."
Print
Print
Print "Press <ANY KEY> to continue!"
Sleep
Cls , 0
Print "At the end of the day though, when all is said and done, you're still the"
Print "one responsible for your own code!"
Print
Print "Use whichever type works for you, and works best for your needs."
Print
Print "Just keep in mind: Various TYPEs come with various limitations on your code."
Print
Print "_BYTE, INTEGER, (both signed and unsigned) are insane to use..."
Print "SINLGE loses precision. Expect to lose whole shades of blue...."
Print "LONG may cause issues with POINT, if compared directly...."
Print "_UNSIGNED LONG works fine, any ONLY stores 32-bit color values...."
Print "_INTEGER64 works fine, and can store extra values if necessary...."
Print "DOUBLE and _FLOAT both work, but are floating point values...."
Print
Print
Print "And with all that said and summed up, it's now up to YOU guys to decide what"
Print "works best in your own programs."
Print
Print
Print "As I said, I personally recommend _UNSIGNED LONG or _INTEGER64 in special cases."
Print "But the choice, and the debugging, is entirely up to YOU. :D"
|
|
|
|
|
