Welcome, Guest |
You have to register before you can post on our site.
|
|
|
Alt-Keys pattern |
Posted by: eoredson - 07-07-2023, 04:52 AM - Forum: Utilities
- Replies (3)
|
|
I have been looking at the keyboard scancodes for the keys Alt-A to Alt-Z and found no pattern to them!
Are they internal to the electronic keyboard itself?
Thanks, Erik.
Here is a program to trap and display them:
Code: (Select All) Rem $Dynamic
DefInt A-Z
Dim Keys(1 To 26) As Integer
' scancodes for Alt-A to Alt-Z.
Data 30,48,46,32,18,33,34,35,23,36,37,38,50,49,24,25,16,19,31,20,22,47,17,45,21,44
' read Alt-<key> data.
For Var = 1 To 26
Read Keys(Var)
Next
Color 15
Print "Press <escape> to exit. Otherwise press Alt-A to Alt-Z."
Color 14
Do
_Limit 50
I$ = InKey$
If Len(I$) Then
If I$ = Chr$(27) Then Color 7: End
End If
If Len(I$) = 2 Then
X = Asc(Right$(I$, 1))
For Z = 1 To 26
If Keys(Z) = X Then
Print "Pressed Alt-"; Chr$(Z + 64); " scan"; X
End If
Next
End If
Loop
End
' scancodes for Alt-A to Alt-Z.
Rem ALT-A = 30
Rem ALT-B = 48
Rem ALT-C = 46
Rem ALT-D = 32
Rem ALT-E = 18
Rem ALT-F = 33
Rem ALT-G = 34
Rem ALT-H = 35
Rem ALT-I = 23
Rem ALT-J = 36
Rem ALT-K = 37
Rem ALT-L = 38
Rem ALT-M = 50
Rem ALT-N = 49
Rem ALT-O = 24
Rem ALT-P = 25
Rem ALT-Q = 16
Rem ALT-R = 19
Rem ALT-S = 31
Rem ALT-T = 20
Rem ALT-U = 22
Rem ALT-V = 47
Rem ALT-W = 17
Rem ALT-X = 45
Rem ALT-Y = 21
Rem ALT-Z = 44
|
|
|
Archive-dot-org simple helper |
Posted by: mnrvovrfc - 07-06-2023, 10:39 PM - Forum: Utilities
- Replies (11)
|
|
This is a program that could make life a bit easier to navigate "archive-dot-org" if the user is only looking to download music or video.
N.B. This requires a bit of research to configure the program as desired. As it stands it only works for audio (FLAC, MP3, OGG, WAV etc.) This research is to obtain the "subjects" which are tags that have to be written precisely into a web address. On "archive-dot-org" some categories are written out like plain English, capitalized short phrases with spaces, which cannot stand into a web address. The site has a chooser of subjects which puts down stuff which could be unpredictable. (Sometimes it chooses "multiple categories" which is the same word or words but in different upper-lower-case combinations.) Therefore the user must tinker a little bit to obtain a subject tag for use with this program. It's a vain attempt to make this program more flexible.
This program requires one text file, and it's recommended to provide another. The required file has one line which is the full path of the executable to the web browser. Because I programmed this on Linux, I'm not familiar with a way to launch the web browser from an user's QB64 program on MacOS or on Windows. I also programmed to launch the AppImage which might appear clumsy to some of you. This file is not provided, you will have to create it. It is called "helparchorg-browser.txt", it must reside in the same directory as the executable. This program only reads the first line of this file, so make sure it has a correct entry.
It's recommended to have also "helparchorg-category.txt". It could also be called "helparchorg-subject.txt". Here you will put down a subject, one per line, for the media that is sought. If you want two categories at a time then put each tag joined by a plus sign. At the moment no more than two categories could be joined.
The program reads the text files, tells the user that it found the web browser, and then shows a menu with the categories. If there's only one then it's "electronic", at the moment, but this could be changed in the source code. The user types in a number for the subject or subjects he/she desires and presses [ENTER]. Pressing [ENTER] with no entry quits the program.
After that, the user is asked what year of creation or release for the media sought, starting with 2013. Again, this could be modified in the source code. Type in the menu choice for the year, not the year itself LOL, and press [ENTER]. Press [ENTER] without entry at this point to leave the program.
This program then launches the web browser with the address fabricated from the data it was given.
Code: (Select All)
'by mnrvovrfc 6-July-2023
OPTION _EXPLICIT
DIM AS INTEGER c, lsubj, j, plu
DIM prefx$, afile$, launchprog$, comd$, asubj$, ayear$, entry$
DIM fe AS LONG
prefx$ = "helparchorg-"
afile$ = prefx$ + "browser.txt"
IF NOT _FILEEXISTS(afile$) THEN
PRINT "The web browser wasn't found! Aborting."
END
END IF
fe = FREEFILE
OPEN afile$ FOR INPUT AS fe
DO UNTIL EOF(fe)
LINE INPUT #fe, entry$
entry$ = _TRIM$(entry$)
IF entry$ <> "" AND launchprog$ = "" THEN
launchprog$ = entry$
EXIT DO
END IF
LOOP
CLOSE fe
IF NOT _FILEEXISTS(launchprog$) THEN
PRINT "The web browser wasn't found! Aborting."
END
END IF
PRINT "Discovered web browser executable called:"
PRINT launchprog$
afile$ = prefx$ + "subject.txt"
IF NOT _FILEEXISTS(afile$) THEN
afile$ = prefx$ + "category.txt"
END IF
IF _FILEEXISTS(afile$) THEN
fe = FREEFILE
OPEN afile$ FOR INPUT AS fe
DO UNTIL EOF(fe)
LINE INPUT #fe, entry$
entry$ = _TRIM$(entry$)
IF entry$ <> "" THEN lsubj = lsubj + 1
LOOP
CLOSE fe
IF lsubj < 1 THEN
PRINT "At least one entry required from input file!"
END
END IF
REDIM subj(1 TO lsubj) AS STRING
c = 0
fe = FREEFILE
OPEN afile$ FOR INPUT AS fe
DO UNTIL EOF(fe)
LINE INPUT #fe, entry$
entry$ = _TRIM$(entry$)
IF entry$ <> "" THEN
c = c + 1
subj(c) = entry$
END IF
LOOP
CLOSE fe
ELSE
lsubj = 1
REDIM subj(1 TO lsubj) AS STRING
subj(lsubj) = "electronic"
END IF
PRINT "*** archive-dot-org helper ***"
IF lsubj = 1 THEN
PRINT: PRINT "There's only one category available: "; subj(1)
asubj$ = subj(1)
ELSE
PRINT: PRINT "Please choose your category."
FOR j = 1 TO lsubj
PRINT USING "(##)"; j;
PRINT " "; subj(j)
NEXT
LINE INPUT entry$
entry$ = _TRIM$(entry$)
IF entry$ = "" THEN SYSTEM
c = VAL(entry$)
IF c > 0 AND c <= lsubj THEN
asubj$ = subj(c)
ELSE
PRINT "Incorrect input given! Aborting."
END
END IF
END IF
PRINT: PRINT "Please choose the year of release."
FOR j = 2013 TO 2023
PRINT USING "(####)"; j - 2012;
PRINT " "; j
NEXT
LINE INPUT entry$
entry$ = _TRIM$(entry$)
IF entry$ = "" THEN SYSTEM
c = VAL(entry$)
IF c > 0 AND c < 12 THEN
ayear$ = _TRIM$(STR$(c + 2012))
ELSE
PRINT "Incorrect input given! Aborting."
END
END IF
comd$ = launchprog$ + " 'https://archive.org/details/audio?and[]=year%3A%22" + ayear$ + _
"%22&and[]=mediatype%3A%22audio%22&and[]=subject%3A%22"
plu = INSTR(asubj$, "+")
IF plu > 0 THEN
comd$ = comd$ + LEFT$(asubj$, plu - 1) + "%22&and[]=subject%3A%22" + MID$(asubj$, plu + 1) + "%22'"
ELSE
comd$ = comd$ + asubj$ + "%22'"
END IF
SHELL _HIDE _DONTWAIT comd$
SYSTEM
For this program as it stands, try this as "helparchorg-category.txt":
Code: (Select All) electronic
podcast
Popular Music+Jazz
|
|
|
Auto reload program upon RUN |
Posted by: Cobalt - 07-06-2023, 08:58 PM - Forum: Help Me!
- Replies (2)
|
|
Anybody have any clever ideas on how one would get the IDE to reload a program when it was run? The program in question actually updates itself when it runs, and I was just wondering if there was a way to get the ide to reload the code so I wouldn't forget to reload it and go change some code save it and destroy the changes the program made last time it ran.
|
|
|
Calculating Anti-Primes |
Posted by: Space_Ghost - 07-06-2023, 06:56 PM - Forum: Works in Progress
- Replies (17)
|
|
Can this be sped up? The code below calculates the first 45 anti-primes in ~6.3 seconds on my W11 PC.
Definition of anti-primes: A natural number that has more divisors (factors, not just prime factors) than any number less that it. For example, 6 has 4 factors, including 1 and itself, and this is more than 1,2,3 or 5 which have only the minimum of 2 factors and 4 which has 3 factors.
Code: (Select All)
'Anti-Primes: Calculate first 45 anti-primes
'date of code: 06 JUL 2023
'Space Ghost (modified QBasic 4.5 from Rosetta Code)
'HOUSEKEEPING -----------------------------------
$CONSOLE:ONLY
OPTION _EXPLICIT
CLS
'VARIABLE DECLARATIONS -------------------------
DIM t AS DOUBLE
DIM tmp AS STRING
DIM AS INTEGER MaxAntiPrime, AntiPrimeCount
DIM AS LONG MaxDivisors, Divisors, n
'MAIN BLOCK ------------------------------------
t = TIMER(0.001)
MaxAntiPrime = 45
n = 0
MaxDivisors = 0
AntiPrimeCount = 0
PRINT "The first 45 anti-primes are:"
PRINT
WHILE AntiPrimeCount < MaxAntiPrime
n = n + 1
Divisors = DivisorCount(n)
IF Divisors > MaxDivisors THEN
PRINT n;
MaxDivisors = Divisors
AntiPrimeCount = AntiPrimeCount + 1
END IF
WEND
PRINT: PRINT
tmp = "Execution Time in secs:##.###"
PRINT USING tmp; TIMER(0.001) - t
END
'FUNCTIONS AND SUBROUTINES ----------------------
FUNCTION DivisorCount (v)
DIM AS LONG total, count, n, p
total = 1
n = v
WHILE n MOD 2 = 0
total = total + 1
n = n \ 2
WEND
p = 3
WHILE (p * p) <= n
count = 1
WHILE n MOD p = 0
count = count + 1
n = n \ p
WEND
p = p + 2
total = total * count
WEND
IF n > 1 THEN total = total * 2
DivisorCount = total
END FUNCTION
'END OF PROGRAM --------------------------------
CONSOLE OUTPUT
The first 45 anti-primes are: 1 2 4 6 12 24 36 48 60 120 180 240 360 720 840 1260 1680 2520 5040 7560 10080 15120 20160 25200 27720 45360 50400 55440 83160 110880 166320 221760 277200 332640 498960 554400 665280 720720 1081080 1441440 2162160 2882880 3603600 4324320 6486480
Execution Time in secs: 6.334
|
|
|
Boring plot of 5000 functions! |
Posted by: mnrvovrfc - 07-05-2023, 10:38 PM - Forum: Works in Progress
- Replies (4)
|
|
This is another program that would only display graphic silliness. Don't expected colored, fractal stuff; a program such as this might have been attempted with QuickBASIC or Turbo Pascal, trying to burn those weak single-core CPU's to a crisp. Many pictures are just an useless line at the top or at the side of the screen. Others are just near-diagonal lines. Others are "steps" as if trying to plot binary or something else. But there are a few good ones here.
The program tries to plot a function with 500 points of Cartesian coordinates taking part in a polar scheme. If the function is not plottable, it's skipped. The "Illegal function call" had to be trapped for it. The functions were fabricated from another QB64 program I wrote. Don't spend too much time looking at them or it will cause some loss of sanity!
Press [ESC] to quit, or on Linux leave it for long enough and then it seg-faults, I don't know why. (shrugs)
At the terminal command line it's possible to follow the executable file's name with an integer from 1 to 5000, to start from the function indicated by the huge "SELECT CASE... END SELECT" block. This has nothing to do with random numbers. It was already taken care of by my "extreme function maker" LOL.
That is the first parameter. There is a second parameter which is a float-type factor. The default is to just plot a circle with X,Y for 500 points. The circle is always created by this program with a "radius" of 2. The factor in this program can only cause the effect of an open shape. In other words, the chosen factor by the user cannot be smaller than the default value of 1.3888.
The actual program is too big to post into this forum, so I'm posting only a portion of it. Otherwise you will have to download the attachment.
Code: (Select All)
'by mnrvovrfc 06-Jun-2023
option _explicit
dim v(1 to 500) as double
dim as double n, x, y, z, mult, factdiv, smaller, largger
dim as integer i, j, cn
dim redu$
if command$(1) = "" then
cn = 1
else
cn = val(command$(1))
if cn = 0 then
cn = 1
elseif cn < 1 or cn > 5000 then
cn = 1
end if
end if
if command$(2) = "" then
mult = 1.3888
else
mult = val(command$(1))
if mult < 1.3888 or mult > 5.0 then
mult = 1.3888
end if
end if
screen _newimage(1000, 500, 12)
for i = cn to 5000
on error goto 100
for z = 1 to 500
x = 2 * cos(_d2r(z / mult))
y = 2 * sin(_d2r(z / mult))
select case i
case 1
n = Z10B46#(x, y, z)
case 2
n = Z10B48#(x, y, z)
case 3
n = Z10B4A#(x, y, z)
case 4
n = Z10B4C#(x, y, z)
case 5
n = Z10B4E#(x, y, z)
case 6
n = Z10B50#(x, y, z)
case 7
n = Z10B52#(x, y, z)
case 8
n = Z10B54#(x, y, z)
case 9
n = Z10B56#(x, y, z)
case 10
n = Z10B58#(x, y, z)
' :
' :
case 4990
n = Z13240#(x, y, z)
case 4991
n = Z13242#(x, y, z)
case 4992
n = Z13244#(x, y, z)
case 4993
n = Z13246#(x, y, z)
case 4994
n = Z13248#(x, y, z)
case 4995
n = Z1324A#(x, y, z)
case 4996
n = Z1324C#(x, y, z)
case 4997
n = Z1324E#(x, y, z)
case 4998
n = Z13250#(x, y, z)
case 4999
n = Z13252#(x, y, z)
case 5000
n = Z13254#(x, y, z)
end select
endoflongcase:
v(z) = n
next
on error goto 0
smaller = 0
largger = 0
for z = 1 to 500
if v(z) < smaller then smaller = v(z)
if v(z) > largger then largger = v(z)
next
if int(smaller * 1e+6) = 0 and int(largger * 1e+6) = 0 then
cls
_continue
end if
redu$ = ""
if abs(smaller) > abs(largger) then factdiv = abs(smaller) else factdiv = abs(largger)
do while factdiv > 1e+6
redu$ = "*"
smaller = smaller / 100
largger = largger / 100
if abs(smaller) > abs(largger) then factdiv = abs(smaller) else factdiv = abs(largger)
loop
_title _trim$(str$(i)) + ": " + redu$ + "Smaller =" + str$(smaller) + "| " + redu$ + "Larger =" + str$(largger)
window screen(smaller, 1)-(largger, 500)
doscreen:
pset(v(1), 1), 15
for z = 2 to 500
line -(v(z), z), 15
next
for j = 1 to 30
_delay 0.1
if _keydown(27) then exit for
next
cls
if _keydown(27) then exit for
next
system
100 n = 0
resume endoflongcase
' :
' :
'then what follows are the functions to plot graphs with.
forceq-graph.bas.zip (Size: 125.59 KB / Downloads: 68)
|
|
|
Fireworks! |
Posted by: Dustinian - 07-04-2023, 05:27 PM - Forum: Programs
- Replies (13)
|
|
This is a fireworks program I've been working on for some time; finally polished it up today in honor of the 4th. Very open to feedback!
Code: (Select All) 'FIREWORK.BAS
'============
'DESCRIPTION
'-----------
' A fireworks screensaver for QBasic.
'AUTHOR
'------
' Dustinian Camburides
'PLATFORM
'--------
' Written in QB64. I hope to make it QBasic-compatible, but no work on that yet.
'VERSION
'-------
'1.0, 2022-09-08: First working version.
'1.1, 2023-07-04: Changed hues by month.
'META
'----
'$DYNAMIC
'USER-DEFINED TYPES
'------------------
TYPE Particle
X0 AS SINGLE 'Current X value of particle (current frame) (used to draw flare point).
Y0 AS SINGLE 'Current Y value of particle (current frame) (used to draw flare point).
X1 AS SINGLE 'Previous X value of particle (last frame) (used to draw bright trail).
Y1 AS SINGLE 'Previous Y value of particle (last frame) (used to draw bright trail).
X2 AS SINGLE 'Previous X value of particle (frame before last) (used to draw dim trail).
Y2 AS SINGLE 'Previous Y value of particle (frame before last) (used to draw dim trail).
Angle AS SINGLE 'Trajectory of particle (degrees).
Velocity AS SINGLE 'Velocity of particle (pixels per frame).
Stage AS INTEGER 'Stage of particle (a particle with one or more stages left will "burst" when the fuse is 0).
Hue AS INTEGER 'The hue of the particle (this the bright color, the program assumes that (Hue MINUS 8) is the dim color).
Fuse AS INTEGER 'The number of frames left before the particle bursts or burns out.
END TYPE
TYPE Hue
Brighter AS INTEGER
Dimmer AS INTEGER
END TYPE
'SUBS
'----
DECLARE SUB Initialize_Hues (Hues() AS Hue)
DECLARE SUB Remove_Particle (Particles() AS Particle, ID AS INTEGER)
DECLARE SUB Append_Particle (Particles() AS Particle, New_Particle AS Particle)
DECLARE SUB Particle_Burst (Current AS Particle, Past AS Particle)
DECLARE SUB Particle_Move (Current AS Particle)
DECLARE SUB Particle_Draw (Current AS Particle, Hues() AS Hue)
DECLARE FUNCTION NewX! (X AS SINGLE, Angle AS SINGLE, Distance AS SINGLE)
DECLARE FUNCTION NewY! (Y AS SINGLE, Angle AS SINGLE, Distance AS SINGLE)
DECLARE FUNCTION RandomBetween% (Minimum AS INTEGER, Maximum AS INTEGER)
'CONSTANTS
'---------
CONST X_MIN = 250 'Minimum X value of firework launch point.
CONST X_MAX = 425 'Maximum X value of firework launch point.
CONST Y_MIN = 350 'Minimum Y value of firework launch point.
CONST Y_MAX = 350 'Maximum Y value of firework launch point.
CONST ANGLE_MIN = 135 'Mimimum angle of firework launch (degrees) (MINUS 180).
CONST ANGLE_MAX = 225 'Maximum angle of firework launch (degrees) (MINUS 180).
CONST VELOCITY_MIN = 5 'Minimum velocity of firework launch (pixels per frame).
CONST VELOCITY_MAX = 12 'Maximum velocity of firework launch (pixels per frame).
CONST STAGE_MIN = 1 'Minimum stages of firework at launch (will burst until 0).
CONST STAGE_MAX = 2 'Maximum stages of firework at launch (will burst until 0).
CONST FUSE_MIN = 20 'Minimum frames the firework will last until the next stage.
CONST FUSE_MAX = 30 'Maximum frames the firework will last until the next stage.
CONST BURST_MIN = 15 'Minimum number of particles that will be produced by a burst.
CONST BURST_MAX = 25 'Maximum number of particles that will be produced by a burst.
CONST DELAY = .04 'The number of seconds between snowflake recalculation / re-draw... QBasic can't detect less than 0.04 seconds...
CONST NEWFIREWORKODDS = 11 'The odds a new firework will be launched.
'VARIABLES
'---------
DIM sngStart AS SINGLE 'The timer at the start of the delay loop.
DIM intParticle AS INTEGER 'The current particle being worked in the loop.
DIM intChildParticles AS INTEGER 'The number of child particles being created after a burst.
DIM intChildParticle AS INTEGER 'The current child particle being worked in the loop.
DIM Fireworks(0) AS Particle 'All of the particles in the fireworks show.
DIM New_Particle AS Particle 'The new particle being created at launch.
DIM Hues(0) AS Hue 'An array of brighter / dimmer firework hues.
'PROCEDURES
'----------
'INITIALIZE SCREEN: Set the screen to mode 9.
'Active page (where the cls, pset, and line commands occur) of 0 and a v
'Visible page (that the user sees) of 1.
'640 X 350
SCREEN 9, , 0, 1: CLS
'INITIALIZE HUES
CALL Initialize_Hues(Hues())
'INITIALIZE TIMER
TIMER ON: RANDOMIZE TIMER
'LOOP EVERY FRAME
WHILE INKEY$ = ""
'Reset current particle...
intParticle = LBOUND(Fireworks)
'Start timer...
sngStart = TIMER
'If we generate a random number within the new firework odds...
IF RandomBetween%(1, 100) <= NEWFIREWORKODDS THEN
'Launch a new firework...
New_Particle.X0 = RandomBetween%(X_MIN, X_MAX)
New_Particle.Y0 = RandomBetween%(Y_MIN, Y_MAX)
New_Particle.X1 = New_Particle.X0
New_Particle.Y1 = New_Particle.Y0
New_Particle.X2 = New_Particle.X0
New_Particle.Y2 = New_Particle.Y0
New_Particle.Angle = RandomBetween%(ANGLE_MIN, ANGLE_MAX) - 180
New_Particle.Velocity = RandomBetween%(VELOCITY_MIN, VELOCITY_MAX)
New_Particle.Stage = RandomBetween(STAGE_MIN, STAGE_MAX)
New_Particle.Hue = RandomBetween(LBOUND(Hues), UBOUND(Hues))
New_Particle.Fuse = RandomBetween(FUSE_MIN, FUSE_MAX)
CALL Append_Particle(Fireworks(), New_Particle)
END IF
'For each particle...
WHILE intParticle <= UBOUND(Fireworks)
'If the fuse is zero...
IF Fireworks(intParticle).Fuse = 0 AND Fireworks(intParticle).Stage > 0 THEN
'Burst the particle...
intChildParticles = RandomBetween%(BURST_MIN, BURST_MAX)
FOR intChildParticle = 0 TO intChildParticles
CALL Particle_Burst(New_Particle, Fireworks(intParticle))
CALL Append_Particle(Fireworks(), New_Particle)
NEXT intChildParticle
END IF
'If the fuse is > -2...
IF Fireworks(intParticle).Fuse > -2 THEN
'Draw the particle...
CALL Particle_Move(Fireworks(intParticle))
CALL Particle_Draw(Fireworks(intParticle), Hues())
'MAYBE ONLY INCREMENT PARTICLES HERE?
intParticle = intParticle + 1 'WE'RE SKIPPING FRAMES SOMETIMES HERE...
ELSE
CALL Remove_Particle(Fireworks(), intParticle)
END IF
WEND
'Wait for the delay to pass before starting over...
WHILE (TIMER < (sngStart + DELAY)) AND (TIMER >= sngStart)
WEND
'Copy the active page (where we just drew the snow) to the visible page...
PCOPY 0, 1
'Clear the active page for the next frame...
CLS
WEND
TIMER OFF
PCOPY 0, 1
END
SUB Initialize_Hues (Hues() AS Hue)
'Sets the hues by month using the default 16-color palette.
SELECT CASE VAL(LEFT$(DATE$, 2))
CASE 2 'February
'Pink and White
REDIM Hues(1) AS Hue
Hues(0).Brighter = 13: Hues(0).Dimmer = 5
Hues(1).Brighter = 15: Hues(1).Dimmer = 7
CASE 3 'March
'Green and White
REDIM Hues(1) AS Hue
Hues(0).Brighter = 10: Hues(0).Dimmer = 2
Hues(1).Brighter = 15: Hues(1).Dimmer = 7
CASE 7 'July
'Red, White, and Blue
REDIM Hues(2) AS Hue
Hues(0).Brighter = 12: Hues(0).Dimmer = 4
Hues(1).Brighter = 15: Hues(1).Dimmer = 7
Hues(2).Brighter = 9: Hues(2).Dimmer = 1
CASE 12 'December
'Red and Green
REDIM Hues(1) AS Hue
Hues(0).Brighter = 12: Hues(0).Dimmer = 4
Hues(1).Brighter = 10: Hues(1).Dimmer = 2
CASE ELSE
'All colors 9-15
REDIM Hues(6) AS Hue
Hues(0).Brighter = 9: Hues(0).Dimmer = 1
Hues(1).Brighter = 10: Hues(1).Dimmer = 2
Hues(2).Brighter = 11: Hues(2).Dimmer = 3
Hues(3).Brighter = 12: Hues(3).Dimmer = 4
Hues(4).Brighter = 13: Hues(4).Dimmer = 5
Hues(5).Brighter = 14: Hues(5).Dimmer = 6
Hues(6).Brighter = 15: Hues(6).Dimmer = 7
END SELECT
END SUB
SUB Remove_Particle (Particles() AS Particle, ID AS INTEGER)
'Note: This would be a lot easier with PRESERVE, but I want to be QB1.1/4.5 compatible... one day.
DIM intMember AS INTEGER
'Create a place to save the data...
DIM Temp(LBOUND(Particles) TO UBOUND(Particles) - 1) AS Particle
'Save the data before the ID...
FOR intMember = LBOUND(Particles) TO ID - 1
Temp(intMember) = Particles(intMember)
NEXT intMember
'Save the data after the ID...
FOR intMember = ID + 1 TO UBOUND(Particles)
Temp(intMember - 1) = Particles(intMember)
NEXT intMember
'Re-create the array with one less row...
REDIM Particles(LBOUND(Temp) TO UBOUND(Temp)) AS Particle
'Re-load the saved data back into the original array...
FOR intMember = LBOUND(TEMP) TO UBOUND(Temp)
Particles(intMember) = Temp(intMember)
NEXT intMember
END SUB
SUB Append_Particle (Particles() AS Particle, New_Particle AS Particle)
'Note: This would be a lot easier with PRESERVE, but I want to be QB1.1/4.5 compatible... one day.
DIM intMember AS INTEGER
'Create a place to save the data...
DIM Temp(LBOUND(Particles) TO UBOUND(Particles)) AS Particle
'Save the data...
FOR intMember = LBOUND(Particles) TO UBOUND(Particles)
Temp(intMember) = Particles(intMember)
NEXT intMember
'Re-create the array with one additional row...
REDIM Particles(LBOUND(Temp) TO UBOUND(Temp) + 1) AS Particle
'Re-load the saved data back into the original array...
FOR intMember = LBOUND(TEMP) TO UBOUND(Temp)
Particles(intMember) = Temp(intMember)
NEXT intMember
'Put the new particle at the end...
Particles(UBOUND(Particles)) = New_Particle
END SUB
SUB Particle_Burst (Current AS Particle, Past AS Particle)
'Basically set the child particle (after the burst) to the properties of its parent.
Current.X0 = Past.X0
Current.Y0 = Past.Y0
Current.X1 = Past.X0
Current.Y1 = Past.Y0
Current.X2 = Past.X0
Current.Y2 = Past.Y0
Current.Angle = RandomBetween%(0, 359)
Current.Velocity = RandomBetween%(2, 4)
Current.Stage = Past.Stage - 1
Current.Hue = Past.Hue
Current.Fuse = RandomBetween(10, 20)
END SUB
SUB Particle_Move (Current AS Particle)
'Move the tail forward.
Current.X2 = Current.X1
Current.X1 = Current.X0
Current.Y2 = Current.Y1
Current.Y1 = Current.Y0
'Move the particle along its current trajectory.
IF Current.Fuse > 0 THEN
Current.X0 = NewX!(Current.X0, Current.Angle, Current.Velocity)
Current.Y0 = NewY!(Current.Y0, Current.Angle, Current.Velocity)
END IF
'Burn Fuse
Current.Fuse = Current.Fuse - 1
END SUB
SUB Particle_Draw (Current AS Particle, Hues() AS Hue)
'Draw oldest segment
LINE (Current.X2, Current.Y2)-(Current.X1, Current.Y1), Hues(Current.Hue).Dimmer
'If the fuse hasn't been burnt out for more than one turn...
IF Current.Fuse > -1 THEN
'Draw newest segment
LINE (Current.X1, Current.Y1)-(Current.X0, Current.Y0), Hues(Current.Hue).Brighter
'If the fuse isn't burnt out...
IF Current.Fuse > 0 THEN
'Draw flare
PSET (Current.X0, Current.Y0), 15
END IF
END IF
END SUB
FUNCTION NewX! (X AS SINGLE, Angle AS SINGLE, Distance AS SINGLE)
NewX! = X + SIN(Angle * 3.141592 / 180) * Distance
END FUNCTION
FUNCTION NewY! (Y AS SINGLE, Angle AS SINGLE, Distance AS SINGLE)
NewY = Y! + ((COS(Angle! * 3.141592 / 180) * Distance!) * -1)
END FUNCTION
FUNCTION RandomBetween% (Minimum AS INTEGER, Maximum AS INTEGER)
RandomBetween% = CINT(Minimum + (RND * (Maximum - Minimum)))
END FUNCTION
|
|
|
|