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: 762
|
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,261
|
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
|
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
|
|
|
Testing Impulse Tracker music file PCM creation and playback |
Posted by: mnrvovrfc - 09-04-2022, 10:40 PM - Forum: Programs
- No Replies
|
|
A silly program to test Impulse Tracker module playback, and PCM data creation from it on QB64 Phoenix Edition v3.1:
Code: (Select All) option _explicit
dim afile$, soundf as long
$IF 64BIT THEN
dim as _integer64 soundbg, soundsz, c
$ELSE
dim as long soundbg, soundsz, c
$END IF
dim b as _mem, bb as _byte, h as _byte
dim sacr$(1 to 10)
randomize (timer mod 16)
afile$ = "retro_expirement.it"
print "Please wait, loading song:"
print afile$
soundf = _sndopen(afile$)
if soundf = -1 then print "Failed to open tracker music.": end
b = _memsound(soundf, 1)
soundbg = ConvertOffset(b.OFFSET)
soundsz = ConvertOffset(b.OFFSET + b.SIZE)
soundsz = soundsz - soundbg
c = 0
h = 1
sacr$(h) = space$(3998)
_sndplay soundf
do while c < soundsz
bb = _memget(b, b.OFFSET + c, _byte)
if bb < 32 then bb = 95
mid$(sacr$(h), p, 1) = chr$(bb)
p = p + 1
if p > 3998 then
p = 1
h = h + 1
if h > 10 then exit do
sacr$(h) = space$(3998)
end if
c = c + 1
loop
do
_limit 10
locate 1, 1
print sacr$(int(rnd * 10 + 1));
if not _sndplaying(soundf) then exit do
loop until _keydown(27)
_sndstop soundf
_sndclose soundf
system
FUNCTION ConvertOffset&& (value AS _OFFSET)
$CHECKING:OFF
DIM m AS _MEM 'Define a memblock
m = _MEM(value) 'Point it to use value
$IF 64BIT THEN
dim i64ret as _integer64
'On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64
_MEMGET m, m.OFFSET, i64ret 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
ConvertOffset&& = i64ret
$ELSE
dim temp&
'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first
_MEMGET m, m.OFFSET, temp& 'Like this
ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
$END IF
_MEMFREE m 'Free the memblock
$CHECKING:ON
END FUNCTION
Download the Impulse Tracker music file from here:
https://modarchive.org/module.php?189056
Press [ESC] to quit the program.
Create executable and copy the IT file you downloaded into the same folder. I'm sorry about hardwiring the value of "afile$". This should work with any module format, the problem is that the longer the song file is, the longer "_SNDOPEN" takes to load it into RAM. Now this could apply to music tracker modules despite their usually being much smaller than MP3 and WAV and formats like that.
|
|
|
Is your computer watching you? |
Posted by: James D Jarvis - 09-04-2022, 05:10 AM - Forum: Programs
- Replies (7)
|
|
Is your computer watching you?
Code: (Select All) 'Your Computer is watching you
'
Screen _NewImage(640, 360, 32)
Randomize Timer
_FullScreen
_Title "The Computer Is Your Friend"
Dim Shared skintonemid As _Unsigned Long
Dim Shared skintonehigh As _Unsigned Long
Dim Shared skintonelow As _Unsigned Long
Dim pk&
pk& = _NewImage(4, 4, 32)
Dim Shared irismid As _Unsigned Long
Dim Shared irishigh As _Unsigned Long
Dim Shared irislow As _Unsigned Long
Dim Shared irisfleck As _Unsigned Long
Dim Shared eyewhite As _Unsigned Long
Do
Cls
ex = _Width / 2
ey = _Height / 2
sred& = 50 + Rnd * 175
sgreen& = 50 + Rnd * 175
sblue& = 50 + Rnd * 175
skintonehigh = _RGB32(sred&, sgreen&, sblue&)
skintonemid = _RGB32(sred& * .8, sgreen& * .9, sblue& * .95)
skintonelow = _RGB32(sred& * .6, sgreen& * .7, sblue& * .6)
Select Case Int(1 + Rnd * 16)
Case 1
ired& = 40
igreen& = 130
iblue& = 20
Case 2, 3
ired& = 50
igreen& = 70
iblue& = 240
Case 4, 5, 6
ired& = 150
igreen& = 200
iblue& = 220
Case 7, 8, 9, 10
ired& = 100
igreen& = 80
iblue& = 60
Case 11, 12, 13
ired& = 200
igreen& = 200
iblue& = 140
Case 14, 15
ired& = 170
igreen& = 180
iblue& = 150
Case 16
ired& = 200
igreen& = 200
iblue& = 23
End Select
irishigh = _RGB32(ired&, igreen&, iblue&)
irismid = _RGB32(ired& * .8, igreen& * .8, iblue& * .8)
irislow = _RGB32(ired& * .6, igreen& * .6, iblue& * .6)
irisfleck = _RGB32(ired& * .6 + Rnd * ired& * .2, igreen * .6 + Rnd * igreen& * .2, iblue * .6 + Rnd * iblue& * .2)
Line (0, 0)-(_Width, _Height), _RGB32(sred& * .9, sgreen& * .9, sblue& * .9), BF
irad = _Width * .15 + Rnd * 6
prad = _Width * .04 + Rnd * (irad * .2)
eyewhite = _RGB32(255 - Rnd * 4, 255 - Rnd * 4, 255 - Rnd * 4)
Circle (ex, ey), irad * 2.5, _RGB32(sred& * .67, sgreen& * .67, sblue& * .67), , , .8
Paint (ex, ey), _RGB32(sred& * .67, sgreen& * .67, sblue& * .67), _RGB32(sred& * .67, sgreen& * .67, sblue& * .67)
Line (0, 0)-(_Width, ey), _RGB32(sred& * .9, sgreen& * .9, sblue& * .9), BF
Circle (ex, ey), irad * 2.5, skintonemid, , , .7
Paint (ex, ey), skintonemid, skintonemid
For ir = irad * 1.2 To irad * 2.5 Step (4 + Rnd * 6)
Circle (ex, ey), ir, skintonehigh, .1, 3.0, 0.7
Next ir
For ir = irad * 2.5 To irad * 1.4 Step -(4 + Rnd * 6)
Circle (ex, ey), ir, skintonelow, 3.2, 0, 0.7
Next ir
Line (ex - irad * 2.5, ey)-(ex - irad * .165, ey - irad + 2), eyewhite
Line -(ex + irad * .165, ey - irad + 2), eyewhite
Line -(ex + irad * 2.5, ey), eyewhite
Line (ex - irad * 2.5, ey)-(ex - irad * .165, ey + irad - 2), eyewhite
Line -(ex + irad * .165, ey + irad - 2), eyewhite
Line -(ex + irad * 2.5, ey), eyewhite
Paint (ex, ey), eyewhite, eyewhite
circleBF ex, ey, irad, irislow
polyT ex + 2, ey - 2, irad * .9, irismid, Int(8 + Rnd * 20)
circleBF ex + 4, ey - 4, irad * .75, irishigh
polyT ex, ey, prad * ((105 + Rnd * 20) / 100), irislow, Int(8 + Rnd * 20)
circleBF ex, ey, prad, _RGB32(Int(Rnd * 9), Int(Rnd * 2), Int(Rnd * 4))
For deg = 0 To 360 Step (1 + Rnd * 6)
x2 = irad * .9 * Sin(0.01745329 * deg)
y2 = irad * .9 * Cos(0.01745329 * deg)
Line (ex, ey)-(ex + x2, ey + y2), irislow
Next deg
circleBF ex + prad, ey - prad, (irad * .6) - prad * .5, _RGB32(255, 255, 255, 40)
circleBF ex, ey, prad, _RGB32(Int(Rnd * 9), Int(Rnd * 2), Int(Rnd * 4))
Do
_Limit 20
ask$ = InKey$
Loop Until ask$ <> ""
Loop Until ask$ = Chr$(27)
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 polyT (cx As Long, cy As Long, r As Long, klr As _Unsigned Long, deg As Long)
setklr klr
d = 0
x = r * Sin(0)
y = r * Cos(0)
While d < 360
d = d + deg
x2 = r * Sin(0.01745329 * d)
y2 = r * Cos(0.01745329 * d)
_MapTriangle (0, 2)-(2, 2)-(2, 0), pk& To(cx, cy)-(cx + x, cy + y)-(cx + x2, cy + y2)
x = x2
y = y2
Wend
End Sub
Sub setklr (klr As _Unsigned Long)
_Dest pk&
Line (0, 0)-(2, 2), klr, BF
_Dest 0
End Sub
Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
fatlineLow x1, y1, x0, y0, r, klr
Else
fatlineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
fatlineHigh x1, y1, x0, y0, r, klr
Else
fatlineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub fatlineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
circleBF x, y, r, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub fatlineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
circleBF x, y, r, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
|
|
|
Big Symmetrical Tree |
Posted by: SierraKen - 09-04-2022, 03:28 AM - Forum: Programs
- Replies (3)
|
|
Well, not exactly symmetrical, but close. So I call it: A Big Tree.
Code: (Select All) 'Big Tree by SierraKen - September 3, 2022.
'Feel free to use this in any code.
'The screen cannot have _RGB32(255, 125, 127) or _RGB32(255, 127, 127) because they use that for points as a plot value.
Screen _NewImage(1000, 600, 32)
_Title "A Big Tree"
start:
_Limit 20
Cls
'sky
blue = 75
For y = 0 To 500
blue = blue + .5
Line (0, y)-(1000, y), _RGB32(0, 0, blue)
Next y
blue = 0
'Ground
green = 75
For y = 501 To 600
green = green + 2
Line (0, y)-(1000, y), _RGB32(0, green, 0)
Next y
green = 0
Line (499, 500)-(501, 480), _RGB32(255, 127, 127), BF
PSet (500, 480), _RGB32(255, 125, 127)
limbsy = 490
size = 115
seconds = 12
seconds2 = 48
For stories = 1 To 6
size = size - 1.5
For yy = 0 To 600
For xx = 0 To 1000
If Point(xx, yy) = _RGB32(255, 125, 127) Then
seconds = seconds - .25
seconds2 = seconds2 + .25
limbsx = xx
limbsy = yy
s = (60 - seconds) * 6 + 180
x = Int(Sin(s / 180 * 3.141592) * size) + limbsx
y = Int(Cos(s / 180 * 3.141592) * size) + limbsy
Line (limbsx + b, limbsy)-(x + b, y), _RGB32(255, 127, 127)
PSet (x, y), _RGB32(255, 125, 127)
s = (60 - seconds2) * 6 + 180
x = Int(Sin(s / 180 * 3.141592) * size) + limbsx
y = Int(Cos(s / 180 * 3.141592) * size) + limbsy
Line (limbsx, limbsy)-(x, y), _RGB32(255, 127, 127)
PSet (x, y), _RGB32(255, 125, 127)
End If
Next xx
Next yy
Next stories
For leaves = 1 To 60000
leafx = Rnd * 1000
leafy = Rnd * 480
If Point(leafx, leafy) = _RGB32(255, 127, 127) Then
For sz = .25 To 4 Step .25
Circle (leafx, leafy + 4), sz, _RGB32(0, 255, 0), , , 2.5
Next sz
End If
Next leaves
Do:
_Limit 20
a$ = InKey$
If a$ = Chr$(27) Then End
Loop
|
|
|
Phoenix Edition v3.1 released! |
Posted by: SMcNeill - 09-04-2022, 02:46 AM - Forum: Announcements
- Replies (36)
|
|
An update that I'm happy to announce, with lots of changes for people to enjoy -- version 3.1 has been released!
Quote:https://github.com/QB64-Phoenix-Edition/...tag/v3.1.0 See GitHub link for full release notes.
Enhancements
- New audio backend using miniaudio
- Miniaudio and a few other libraries have replaced the OpenAL-based audio backend that was previously used. - This fixes licensing concerns with using OpenAL, which was LGPL licensed. - Newly supported formats include flac, mod, s3m, xm, it, rad
. - Image backend enhancements - Support for pcx images was added.
- _LOADIMAGE was improved to support loading 256-color images.
- Add _ROR & _ROL support.
Bug Fixes
- Use -no-pie on Linux, fixes running compiled executables from file browsers
- Remove DPI Awareness on Windows, QB64 executables will properly scale based on the OS setting
Full Changelog: https://github.com/QB64-Phoenix-Edition/...0...v3.1.0
So what's this mean for you guys, as our users?
For starters, the image library was more or less replaced completely. We now offer support for both PCX images and 256 color images with _LOADIMAGE. Even more importantly, as far as most of you guys are concerned, I'm certain: We now load images much faster than previously! "How much faster", you ask? That depends on the image type in particular, but I imagine nearly every type should see somewhere between a 20% - 50% reduction in load times.
We offer more image formats, and we load them faster than ever! What's not to love about that??
On top of this change, the sound libraries were replaced and redone. We no longer link to the evil library which required a LGPL License when in use. You can now use sound and enjoy a more more lenient license. (Read the license file for a fell breakdown and detail of everything, please.) We've also expanded formats which we support with our sound library, and we should have corrected the issue with stereo sound only coming from a single monochannel speaker.
Linux users should no longer have the issues of QB64 programs not running if they click on them in the file explorer.
Windows users should no longer have issues with windows not scaling to match DPI Awareness settings on high resolution screens.
Everyone should now be able to enjoy the new _ROR and _ROL, which are used for bit rotation right and left. (Rotate Right = RoR, Rotate Left = RoL).
Download can be grabbed from here: Release v3.1.0 · QB64-Phoenix-Edition/QB64pe (github.com)
|
|
|
Nonsense Forest |
Posted by: James D Jarvis - 09-03-2022, 09:22 PM - Forum: Programs
- Replies (5)
|
|
I got inspired by other folks tree programs and decided to spend part of my birthday making one to share.
Mostly new code aside from a few subs I may or may not have shared in the past.
Code: (Select All) 'nonsense_forest
'it's my birthday so I made some fun colorful code to share
'
'$dynamic
Screen _NewImage(1000, 600, 32)
_Title "Nonsense Forest - Press any key for another forest - Esc to end"
Randomize Timer
Dim Shared rootx, trunkl, twidth
Dim bx(0, 0) As Integer, by(0, 0) As Integer, bwid(0) As Integer, blen(0) As Integer
Do
_Limit 20
Cls
skyr = 200 - Rnd * (20): skyg = 220 - Rnd * 20: skyb = 255 - Rnd * 20
For y = 0 To _Height * .65
Line (0, y)-(_Width, y), _RGB32(skyr, skyg, skyb)
skyr = skyr - .5: skyg = skyg - .25: skyb = skyb - .12
Next y
grr = 20 + Rnd * 10: grg = 20 + Rnd * 10: grb = 20 + Rnd * 20
For y = _Height * .648 To _Height
Line (0, y)-(_Width, y), _RGB32(grr, grg, grb)
grr = grr - .5: grg = grg + 1: grb = grb + .2
Next y
rootx = 0
rooty = _Height * .67
trees = Int(12 + Rnd * 36)
'trees = 3
For treecount = 1 To trees
branch = Int(2 + Rnd * 8)
' Do
' _Limit 20
' Input "branch stages ? (2 to 12) ", branch
'Loop Until branch > 1 And branch < 13
ReDim bx(branch, 2 ^ branch) As Integer
ReDim by(branch, 2 ^ branch) As Integer
ReDim bwid(branch)
ReDim blen(branch)
rootx = rootx + 12 + (Rnd * 24) * 10
If rootx > _Width * .9 Then
rootx = _Width * .1 + Rnd * 10
rooty = rooty + _Height * .1 + Rnd * 24
End If
rooty = rooty + Rnd * 5 - Rnd * 5
twid = Int((8 + Rnd * 10) / 2)
trunk = _Height / (branch + 10)
bx(1, 1) = rootx
by(1, 1) = rooty - trunk
bwid(1) = twid
blen(1) = trunk
klr = _RGB32(50 + Rnd * 200, 100 + Rnd * 150, 100 + Rnd * 150)
bumpyline rootx, rooty, bx(1, 1), by(1, 1), bwid(1), klr
For n = 2 To branch
bwid(n) = bwid(n - 1) * .75
If bwid(n) < 0.5 Then bwid(n) = 0.5
blen(n) = blen(n - 1) / 2 + Rnd * (blen(n - 1) * .75)
If blen(n) < trunk * .2 Then blen(n) = trunk
For b = 1 To 2 ^ (n - 1)
x1 = bx(n - 1, (b + 1) \ 2)
y1 = by(n - 1, (b + 1) \ 2)
If b Mod 2 = 0 Then
x2 = x1 + blen(n - 1) / 2 + Rnd * blen(n)
Else
x2 = x1 - blen(n - 1) / 2 - Rnd * blen(n)
End If
y2 = y1 - (blen(n) / 2 + Rnd * blen(n))
bx(n, b) = x2
by(n, b) = y2
If b > 1 Then
If bx(n, b) = bx(n, b - 1) And by(n, b) = by(n, b - 1) Then
If bx(n, b) > rootx Then
bx(n, b) = bx(n, b) + blen(n - 1) / 4 + Rnd * blen(n - 1)
by(n, b) = by(n, b) + blen(n - 1) / 4 + Rnd * blen(n - 1)
Else
bx(n, b) = bx(n, b) - blen(n - 1) / 4 + Rnd * blen(n - 1)
by(n, b) = by(n, b) + blen(n - 1) / 4 + Rnd * blen(n - 1)
End If
End If
End If
Next b
Next n
fr = Int(1 + Rnd * 200): fg = Int(1 + Rnd * 200): fb = Int(1 + Rnd * 200)
x1 = bx(branch, 1): x2 = bx(branch, 2 ^ branch)
'Print x1, x2
y1 = by(branch, 2): y2 = by(branch, 2 ^ branch)
avX = (x1 + x2) / 2: avy = (y1 + y2) / 2
' For t = 1 To branch * 3
'polyT avX, avy, Int(10 + Rnd * 50), _RGB32(fr + Int(Rnd * 12), fg + Int(Rnd * 12), fb + Int(Rnd * 12)), Int(31 + Rnd * 140)
' Next t
jagmuch = Int(Rnd * 5)
jagx = Int(3 + Rnd * 10)
jagy = Int(3 + Rnd * 10)
For n = 1 To branch - 1
For b = 1 To 2 ^ (n - 1)
If n = branch - 1 Then
polyT bx(n + 1, b * 2 - 1), by(n + 1, b * 2 - 1), bwid(n) * 10 + Rnd * (bwid(n) * 5), _RGB32(fr + Rnd * 30, fg + Rnd * 30, fb + Rnd * 30), Int(11 + Rnd * 140)
polyT bx(n + 1, b * 2), by(n + 1, b * 2), bwid(n) * 10 + Rnd * (bwid(n) * 5), _RGB32(fr + Rnd * 30, fg + Rnd * 30, fb + Rnd * 30), Int(11 + Rnd * 140)
End If
If jagmuch < 2 Then
bumpyline bx(n, b), by(n, b), bx(n + 1, b * 2 - 1), by(n + 1, b * 2 - 1), bwid(n), klr
bumpyline bx(n, b), by(n, b), bx(n + 1, b * 2), by(n + 1, b * 2), bwid(n), klr
Else
jx = bx(n, b)
jy = by(n, b)
For j = 2 To jagmuch
jx2 = jx + Int(Rnd * jagx) - Int(Rnd * jagx)
jy2 = jy + Int(Rnd * jagy) / 2 - Int(Rnd * jagy)
bumpyline jx, jy, jx2, jy2, bwid(n), klr
jy = jy2
jx = jx2
Next j
bumpyline jx, jy, bx(n + 1, b * 2 - 1), by(n + 1, b * 2 - 1), bwid(n), klr
jx = bx(n, b)
jy = by(n, b)
For j = 2 To jagmuch
jx2 = jx + Int(Rnd * jagx) - Int(Rnd * jagx)
jy2 = jy + Int(Rnd * jagy) / 2 - Int(Rnd * jagy)
bumpyline jx, jy, jx2, jy2, bwid(n), klr
jy = jy2
jx = jx2
Next j
bumpyline jx, jy, bx(n + 1, b * 2), by(n + 1, b * 2), bwid(n), klr
End If
If n = branch - 1 Then
cxa = bx(n + 1, b * 2 - 1)
cya = by(n + 1, b * 2 - 1)
cxb = bx(n + 1, b * 2)
cyb = by(n + 1, b * 2)
tuftlim = Int(12 + Rnd * 12)
For tufts = 3 To tuftlim
cx = cxa + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
cy = cya + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
rf = fr + Int(Rnd * 30): gf = fg + Int(Rnd * 30): bf = fb + Int(Rnd * 30)
If cx > bx(n + 1, b) Then
rf = rf + 10
gf = gf + 20
bf = bf + 10
End If
r = 12 + Rnd * (bwid(n) * 5)
' circleBF cx, cy, r, _RGB32(rf, gf, bf)
polyT cx, cy, r, _RGB32(rf, gf, bf), Int(31 + Rnd * 140)
Next
For tufts = 3 To tuftlim
cx = cxb + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
cy = cyb + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
rf = fr + Int(Rnd * 30): gf = fg + Int(Rnd * 30): bf = fb + Int(Rnd * 30)
If cx > bx(n + 1, b) Then
rf = rf + 10
gf = gf + 20
bf = bf + 10
End If
r = 12 + Rnd * (bwid(n) * 5)
'circleBF cx, cy, r, _RGB32(rf, gf, bf)
polyT cx, cy, r, _RGB32(rf, gf, bf), Int(31 + Rnd * 140)
Next
End If
Next b
Next n
Next treecount
Do
_Limit 20
ask$ = InKey$
Loop Until ask$ <> ""
Loop Until ask$ = Chr$(27)
Sub bumpyline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
bumpylineLow x1, y1, x0, y0, r, klr
Else
bumpylineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
bumpylineHigh x1, y1, x0, y0, r, klr
Else
bumpylineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub bumpylineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
nr = r + (1 * Rnd * (r / 2)) - (1 * Rnd(r / 2))
circleBF x, y, nr, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub bumpylineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
nr = r + (1 * Rnd * (r / 2)) - (1 * Rnd(r / 2))
circleBF x, y, nr, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
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 polyT (cx As Long, cy As Long, r As Long, klr As _Unsigned Long, deg As Long)
setklr klr
d = 0
x = r * Sin(0)
y = r * Cos(0)
While d < 360
d = d + deg
x2 = r * Sin(0.01745329 * d)
y2 = r * Cos(0.01745329 * d)
_MapTriangle (0, 2)-(2, 2)-(2, 0), pk& To(cx, cy)-(cx + x, cy + y)-(cx + x2, cy + y2)
x = x2
y = y2
Wend
End Sub
Sub setklr (klr As Long)
_Dest pk&
Line (0, 0)-(2, 2), klr, BF
_Dest 0
End Sub
|
|
|
Space Lander |
Posted by: james2464 - 09-03-2022, 01:22 AM - Forum: Works in Progress
- Replies (22)
|
|
Exploring moving/controlling an object etc...very fun project
No collisions yet, no sound. Control with w, a, d keys
Cheers
Code: (Select All) 'Lander
'james2464
'Sept 2 2022
Dim scx, scy As Integer
'screen size
scx = 1100 ' 640 min --- 1600 max made for 1100
scy = 600 ' 480 min --- 700 max made for 600
Screen _NewImage(scx, scy, 32)
Randomize Timer
Const PI = 3.141592654#
Dim c0(100) As Long
c0(0) = _RGB(0, 0, 0)
c0(1) = _RGB(255, 255, 255, 60)
c0(2) = _RGB(255, 0, 0)
c0(3) = _RGB(150, 150, 255)
c0(4) = _RGB(0, 200, 50)
c0(5) = _RGB(100, 100, 100)
c0(6) = _RGB(50, 50, 50)
c0(7) = _RGB(255, 50, 50)
c0(8) = _RGB(125, 125, 200)
c0(9) = _RGB(0, 125, 255)
c0(10) = _RGB(255, 200, 125)
c0(11) = _RGB(20, 20, 20)
c0(30) = _RGBA32(255, 255, 150, 160) 'ship exhaust
c0(31) = _RGBA32(255, 255, 150, 80) 'ship exhaust
c0(32) = _RGBA32(255, 255, 150, 40) 'ship exhaust
c0(33) = _RGBA32(255, 255, 150, 20) 'ship exhaust
c0(34) = _RGBA32(255, 220, 0, 200) 'ship exhaust
c0(35) = _RGBA32(255, 220, 0, 100) 'ship exhaust
c0(36) = _RGBA32(255, 220, 0, 70) 'ship exhaust
c0(37) = _RGBA32(255, 220, 0, 40) 'ship exhaust
c0(38) = _RGBA32(255, 220, 0, 10) 'ship exhaust
c0(39) = _RGBA32(255, 220, 0, 0) 'ship exhaust
Dim xx, yy
xx = scx / 2
yy = scy / 2
Type BB
live As Integer
x As Single
y As Single
xv As Single
yv As Single
age As Integer
rad As Integer
spd As Single
colour As Integer
End Type
Dim bnb(900) As BB
Cls
'lower random landscape
j = 0
jj = 0
k = 170
Do
j = j + 1
jj = jj + 1
If jj > 8 Then
r = Int(Rnd * 5) - 2
jj = 0
End If
k = k + r
If k > 220 Then
k = k - r
End If
If k < 120 Then
k = k - r
End If
Line (j, scy - k)-(j, scy), c0(6)
Loop Until j >= scx
'upper random landscape
j = 0
jj = 0
k = scy / 6
Do
j = j + 1
jj = jj + 1
If jj > 8 Then
r = Int(Rnd * 5) - 2
jj = 0
End If
k = k + r
If k > (scy / 5) Then
k = k - r
End If
If k < scy / 9 Then
k = k - r
End If
Line (j, 0)-(j, k), c0(6)
Loop Until j >= scx
'===== ground
Line (0, scy - 20)-(scx, scy), c0(5), BF
'===== right wall
Line (scx - 40, 0)-(scx, scy - 20), c0(5), BF
'===== left wall
Line (0, 0)-(40, scy - 20), c0(5), BF
'===== pad 1
Line (100, yy)-(200, scy - 80), c0(0), BF
Line (100, scy - 80)-(200, scy - 78), c0(4), BF
'===== pad 2
Line (280, yy)-(355, scy - 50), c0(0), BF
Line (280, scy - 50)-(355, scy - 48), c0(4), BF
'===== pad 3
Line (380 + (scx - 480) / 6, yy)-(430 + (scx - 480) / 6, scy - 90), c0(0), BF
Line (380 + (scx - 480) / 6, scy - 90)-(430 + (scx - 480) / 6, scy - 88), c0(4), BF
'===== pad 4
Line (scx - 120, yy)-(scx - 160, scy - 50), c0(0), BF
Line (scx - 120, scy - 50)-(scx - 160, scy - 48), c0(4), BF
'Sleep
'===== parameters
flow = 1
dv = .033 ' time delay value
pt = 2 ' point size aka circle size
fan = 30 ' fountain fan size
cc1 = 1 ' colour 1
cc2 = 4 ' colour 2
ls = 4 ' launch speed
Dim blive, maxb As Integer
blive = 1
maxb = 1
flip = 0
stx = scx - 140
sty = scy - 70
bnb(1).live = 1
bnb(1).colour = 3
bnb(1).x = stx
bnb(1).y = sty
j = 1
'======== main loop
Do
flag = 0
Do
'update screen
'erase ship
cc = 0
Line (bnb(j).x - 16, bnb(j).y - 15)-(bnb(j).x + 16, bnb(j).y + 19), c0(cc), BF
'find what's changed before drawing ship again
'what colour pixels are beneath the ship?
'if not black, then it has touched down or collided
c0(99) = Point(bnb(j).x, bnb(j).y + 20)
If c0(99) <> c0(0) Then
ccflag = 1 'contact
Else
ccflag = 0 'no contact
End If
gravityadd = .03
bnb(j).yv = bnb(j).yv + gravityadd
If ccflag = 0 Then 'if ship is flying
'=============== player input
If _KeyDown(119) Then
bnb(j).yv = bnb(j).yv - .2
fire = 1
End If
If bnb(j).yv > 10 Then bnb(j).yv = 10
If bnb(j).yv < -10 Then bnb(j).yv = -10
If _KeyDown(97) Then
bnb(j).xv = bnb(j).xv - .1
fire = 2
End If
If bnb(j).xv < -5 Then bnb(j).xv = -5
If _KeyDown(100) Then
bnb(j).xv = bnb(j).xv + .1
fire = 3
End If
If bnb(j).xv > 5 Then bnb(j).xv = 5
cc = 3 'normal ship colour
'if ship is not landed anywhere
bnb(j).x = bnb(j).x + bnb(j).xv
bnb(j).y = bnb(j).y + bnb(j).yv
If bnb(j).x < 50 Then bnb(j).x = 50
If bnb(j).x > scx - 50 Then bnb(j).x = scx - 50
If bnb(j).y < 10 Then bnb(j).y = 10
If bnb(j).y > scy - 30 Then bnb(j).y = scy - 30
'ship
Line (bnb(j).x - 3, bnb(j).y - 15)-(bnb(j).x + 3, bnb(j).y - 14), c0(cc), BF
Line (bnb(j).x - 5, bnb(j).y - 13)-(bnb(j).x + 5, bnb(j).y - 11), c0(cc), BF
Line (bnb(j).x - 6, bnb(j).y - 10)-(bnb(j).x + 6, bnb(j).y + 4), c0(cc), BF
Line (bnb(j).x - 6, bnb(j).y - 12)-(bnb(j).x - 16, bnb(j).y + 19), c0(cc)
Line (bnb(j).x + 6, bnb(j).y - 12)-(bnb(j).x + 16, bnb(j).y + 19), c0(cc)
Line (bnb(j).x - 16, bnb(j).y + 19)-(bnb(j).x - 6, bnb(j).y + 4), c0(cc)
Line (bnb(j).x + 16, bnb(j).y + 19)-(bnb(j).x + 6, bnb(j).y + 4), c0(cc)
Line (bnb(j).x - 1, bnb(j).y + 5)-(bnb(j).x + 1, bnb(j).y + 5), c0(cc) 'engine
Line (bnb(j).x - 2, bnb(j).y + 6)-(bnb(j).x + 2, bnb(j).y + 6), c0(cc) 'engine
Line (bnb(j).x - 3, bnb(j).y + 7)-(bnb(j).x + 3, bnb(j).y + 7), c0(cc) 'engine
'ship exhaust
If fire = 1 Then
cc = 30
Line (bnb(j).x - 2, bnb(j).y + 8)-(bnb(j).x + 2, bnb(j).y + 9), c0(30), BF
Line (bnb(j).x - 2, bnb(j).y + 10)-(bnb(j).x + 2, bnb(j).y + 10), c0(31), BF
Line (bnb(j).x - 2, bnb(j).y + 11)-(bnb(j).x + 2, bnb(j).y + 12), c0(32), BF
Line (bnb(j).x - 2, bnb(j).y + 13)-(bnb(j).x + 2, bnb(j).y + 15), c0(33), BF
'PSet (bnb(j).x, bnb(j).y + 16), c0(33)
ElseIf fire = 2 Then
cc = 31
Line (bnb(j).x + 7, bnb(j).y - 5)-(bnb(j).x + 12, bnb(j).y - 4), c0(cc), BF
ElseIf fire = 3 Then
cc = 31
Line (bnb(j).x - 7, bnb(j).y - 5)-(bnb(j).x - 12, bnb(j).y - 4), c0(cc), BF
End If
fire = 0
Else 'ship is touching down
'=============== player input
If _KeyDown(119) Then
bnb(j).yv = bnb(j).yv - .2
fire = 1
End If
If bnb(j).yv > 10 Then bnb(j).yv = 10
If bnb(j).yv < -10 Then bnb(j).yv = -10
'If _KeyDown(97) Then bnb(j).xv = bnb(j).xv - .1
'If _KeyDown(100) Then bnb(j).xv = bnb(j).xv + .1
'If bnb(j).xv > 5 Then bnb(j).xv = 5
'If bnb(j).xv < -5 Then bnb(j).xv = -5
cc = 3 'ship landed alt colour
'if ship is landed
bnb(j).xv = bnb(j).xv * .6 'cancel out most of existing x velocity
If bnb(j).yv > 0 Then bnb(j).yv = 0 'cancel y velocity if heading down
bnb(j).x = bnb(j).x + bnb(j).xv
bnb(j).y = bnb(j).y + bnb(j).yv 'since y velocity can only be upward, go for it
If bnb(j).x < 50 Then bnb(j).x = 50
If bnb(j).x > scx - 50 Then bnb(j).x = scx - 50
If bnb(j).y < 10 Then bnb(j).y = 10
If bnb(j).y > scy - 30 Then bnb(j).y = scy - 30
'ship
Line (bnb(j).x - 3, bnb(j).y - 15)-(bnb(j).x + 3, bnb(j).y - 14), c0(cc), BF
Line (bnb(j).x - 5, bnb(j).y - 13)-(bnb(j).x + 5, bnb(j).y - 11), c0(cc), BF
Line (bnb(j).x - 6, bnb(j).y - 10)-(bnb(j).x + 6, bnb(j).y + 4), c0(cc), BF
Line (bnb(j).x - 6, bnb(j).y - 12)-(bnb(j).x - 16, bnb(j).y + 19), c0(cc)
Line (bnb(j).x + 6, bnb(j).y - 12)-(bnb(j).x + 16, bnb(j).y + 19), c0(cc)
Line (bnb(j).x - 16, bnb(j).y + 19)-(bnb(j).x - 6, bnb(j).y + 4), c0(cc)
Line (bnb(j).x + 16, bnb(j).y + 19)-(bnb(j).x + 6, bnb(j).y + 4), c0(cc)
Line (bnb(j).x - 1, bnb(j).y + 5)-(bnb(j).x + 1, bnb(j).y + 5), c0(cc) 'engine
Line (bnb(j).x - 2, bnb(j).y + 6)-(bnb(j).x + 2, bnb(j).y + 6), c0(cc) 'engine
Line (bnb(j).x - 3, bnb(j).y + 7)-(bnb(j).x + 3, bnb(j).y + 7), c0(cc) 'engine
'ship exhaust
If fire = 1 Then
cc = 30
Line (bnb(j).x - 2, bnb(j).y + 8)-(bnb(j).x + 2, bnb(j).y + 9), c0(30), BF
Line (bnb(j).x - 2, bnb(j).y + 10)-(bnb(j).x + 2, bnb(j).y + 10), c0(31), BF
Line (bnb(j).x - 2, bnb(j).y + 11)-(bnb(j).x + 2, bnb(j).y + 12), c0(32), BF
Line (bnb(j).x - 2, bnb(j).y + 13)-(bnb(j).x + 2, bnb(j).y + 15), c0(33), BF
'PSet (bnb(j).x, bnb(j).y + 16), c0(33)
End If
fire = 0
End If
blink = blink + 1
If blink < 25 Then
bk = 0
End If
If blink > 24 Then
bk = 2
End If
If blink > 50 Then blink = 0
If ccflag = 0 Then
Line (bnb(j).x - 1, bnb(j).y - 10)-(bnb(j).x + 1, bnb(j).y - 8), c0(bk), BF
Else
Line (bnb(j).x - 1, bnb(j).y - 10)-(bnb(j).x + 1, bnb(j).y - 8), c0(4), BF
End If
_Delay dv
Loop Until flag = 1
Loop
End
|
|
|
a TON of source code and projects archived from PlanetSourceCode.com |
Posted by: madscijr - 09-02-2022, 10:41 PM - Forum: General Discussion
- Replies (25)
|
|
Remember Planetsourcecode.com and all the VB4,5,6 projects there?
Well, someone backed up a good chunk of it, and put it on github, categorized, and with the original program descriptions / screenshots / ZIP files / etc.
This will take days / weeks / months to go through, but I am seeing some really neat stuff there.
The classic VB stuff alone will provide plenty of ideas for future QB64 projects, algorithms, etc., so I just wanted to post the URL for anyone interested.
Index: https://github.com/Planet-Source-Code/PSCIndex
By Category: https://github.com/Planet-Source-Code/PS...ByCategory
- Submissions by Worlds
- Submissions by Categories
- Submissions by Authors
- All Time Best Code/Article/Tutorial Hall of Fame
- All Submissions (with Search)
By language ("worlds"):
World (# Categories) (# Submissions)
Visual Basic (27) (15222)
C / C++ (25) (415)
ASP / VbScript (24) (326)
Java (26) (271)
.Net (C#, VB.net) (21) (226)
PHP (19) (144)
Delphi (14) (51)
Enjoy and have a great weekend...
|
|
|
Tree Maker |
Posted by: SierraKen - 09-02-2022, 06:32 PM - Forum: Programs
- Replies (4)
|
|
I know B+ has made a better one awhile back, but I've wanted to make one of these myself for years and FINALLY did it!!
It doesn't add leaves but it makes the trunk and random branches. And the land line.
It finally came to me this morning to just use PSET color plot points and to loop it and at every loop it also scans to find those PSET color plot points.
It's very simple if you take a look at the code and play around with it.
In the comments I added the PSET color not to use anywhere else on the screen for your own programs since that's where it needs those points. In the code I put where you can play around with other numbers on 2 lines.
Press the Space Bar to make another random tree.
The funny thing is, I was trying to do this yesterday but ended up making the Tesla Coil instead.
Code: (Select All) 'Tree Maker by SierraKen - September 2, 2022.
'Feel free to use this in any code.
'The screen cannot have _RGB32(255, 125, 127) because it uses that PSET point as a plot value.
Screen _NewImage(800, 600, 32)
_Title "Tree Maker - Press Space Bar for another tree - Esc to end"
start:
_Limit 20
Cls
Line (0, 500)-(800, 500), _RGB32(127, 255, 127)
Line (397, 500)-(403, 480), _RGB32(255, 127, 127), BF
PSet (400, 480), _RGB32(255, 125, 127)
limbsy = 490
size = 60
For stories = 1 To 5 '<<<<<<< Experiment with this number.
size = size - 3 '<<<<<<< Experiment with this number.
For yy = 0 To 600
For xx = 0 To 800
If Point(xx, yy) = _RGB32(255, 125, 127) Then
limbsx = xx
limbsy = yy
seconds = (Rnd * 8) + 5
s = (60 - seconds) * 6 + 180
x = Int(Sin(s / 180 * 3.141592) * size) + limbsx
y = Int(Cos(s / 180 * 3.141592) * size) + limbsy
For b = 2 To -2 Step -.1
Line (limbsx + b, limbsy)-(x + b, y), _RGB32(255, 127, 127)
Line (limbsx + b, limbsy)-(x + b, y), _RGB32(255, 127, 127)
Next b
PSet (x, y), _RGB32(255, 125, 127)
seconds = (Rnd * 9) + 47
s = (60 - seconds) * 6 + 180
x = Int(Sin(s / 180 * 3.141592) * size) + limbsx
y = Int(Cos(s / 180 * 3.141592) * size) + limbsy
For b = 2 To -2 Step -.1
Line (limbsx + b, limbsy)-(x + b, y), _RGB32(255, 127, 127)
Line (limbsx + b, limbsy)-(x + b, y), _RGB32(255, 127, 127)
Next b
PSet (x, y), _RGB32(255, 125, 127)
End If
Next xx
Next yy
Next stories
Do:
_Limit 20
a$ = InKey$
If a$ = " " Then GoTo start:
If a$ = Chr$(27) Then End
Loop
|
|
|
Call a video from QB64 |
Posted by: Kernelpanic - 09-02-2022, 05:06 PM - Forum: General Discussion
- Replies (3)
|
|
Actually, no new routine for calling a video has to be worked into QB64, it can also be done that way.
One can call a program for playing videos created in Visual Basic with "Run" from QB64. In the example, programs and video are in the same directory, but this is not necessary.
Let's see if you can also call up a player directly. Would be even easier.
Code: (Select All) 'VisualBasic Videoprogramm aufrufen - 2. Sept. 2022
Print
Print "Ruft ein VisualBasic Programm zum Abspielen von Videos auf."
Print
Print "Weiter mit beliebiger Taste . . ."
Do
Loop While InKey$ = ""
'Aufruf des VB-Programms
Run "Video-abspielen.exe"
End
|
|
|
"Well I don't give a damn about my bad reputation." |
Posted by: TDarcos - 09-02-2022, 04:44 PM - Forum: General Discussion
- Replies (16)
|
|
"Well I don't give a damn about my bad reputation."
- Joan Jett, Bad Reputation
Basic has gotten a bad reputation, some of it deserved, some of it "sneering" by people who use "real" programming languages. Or they don't know, or don't realize, the Basic languages of today "are not your father's Basic." Let's look at some of the criticisms people have of basic.
- Requires line numbers. Basic hasn't "required" line numbers for over 30 years. Most of the "world-class" compilers (and interpreters) support line numbers if needed, but labels may be used. It is entirely possible to write functional Basic programs without needing line numbers or labels.
- Only allows short (1 or 2 character variable names). This restriction hasn't been present in Basic for over 40 years. And variables can include the underline _ as a separator.
- Variables have to be identified by a type symbol, e.g. % for integer, $ for string, etc. This is done as a convenience, so variables can be "defined" when used, and the compiler will know what the variable is used for. It is also provided for backward compatibility. You can declare a variable as a certain type before use, (e.g. DEFINE MyName AS STRING), declare certain variables beginning with certain letters have a default data type, and can even require all variables be declared before use.
- Requires declaring assignments by using "LET" as a prefix. Developments in scanning eliminated that requirement back in the 1970s. The LET keyword is kept strictly for backward compatibility.
- Produces "spaghetti code." When programs were written on an "ad hoc" or "seat of the pants" methods, yes, you got programs that jumped all over the place, and had no consistency. But this was true of any language that lacked good control structures, had line labels, and no means other than GOTO and IF statements to choose code paths. This includes C, Fortran and Cobol. It is possible, even when all Basic had for program control and branching were GOTO, GOSUB, and IF x THEN GOTO, to write structured or cohesive programs that were more-or-less consistent in using structure in code.
- Weak or inadequate control structures. Basic has all the control structures supported by other high-level languages, including: WHILE, CASE, FOR, IF statement block, procedures (SUB) and functions.
- Lacks support for structures or records. The TYPE statement allows creation of a structured record. Fields in a structure can be accessed using the standard variable.field notation.
- You can't access external routines written in other languages. External routines can be called, and any of the common calling conventions may be used.
- No database support. Since external routines can be accessed, any database system that provides a shared library for database access can be used.
- Only supports short (<256 byte) strings. Basic supports virtually unlimited length of strings. I wrote a short (<10 line) program to double the length of a string on each iteration of a loop. After 26 iterations, I had concatenated a string that was over 130 million characters long. Not that you're likely to need to work with strings that long, it is trivially easy to handle 1K or 100K strings in a Basic program.
- No dynamic memory. Basic supports pointers, creation of dynamically allocated structures (records) using the NEW keyword. Basic supports dynamic arrays that can be shrunk or expanded.
- Is trivially easy to learn. This is a criticism? You can go online and find videos on YouTube to teach C++ in 10 hours. The fact that Basic can be picked up by a person not familiar with programming even faster than this does not mean the language is a "toy." Basic can and has been used to develop professional applications. It just happens to have a gentler learning curve than other programming languages is a strength, not a weakness. It also creates an advantage, in that once you learn one programming language, it's easier to pick up others. Basic's ease of use may make it appear to be less capable than other languages, but it is usable by professionals to actually accomplish real work.
- Can't be used for GUI applications or anything other than for text applications. Some versions of Basic support Windows forms. One supports the WXWidgets GUI framework. Others support Windows WIN32 API, or other GUI frameworks. Most Basics support line drawing and other graphical image drawing functions.
In short, many people have misconceptions of Basic, based on reasons that are either flatly incorrect, or were fixed decades ago.
|
|
|
|