|
|
Post by bplus on Jul 4, 2024 20:11:49 GMT
earliest(for me)
_Title "Fireworks 3 translation to QB64 2017-12-26 bplus"
'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09
'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris
'fireworks 3.bas try with map variables make bursts around a central point
Const xmax = 1000
Const ymax = 720
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 180, 0
Type placeType
x As Single
y As Single
End Type
Type flareType
x As Single
y As Single
dx As Single
dy As Single
c As Long
End Type
Type debrisType
x As Single
y As Single
c As Long
End Type
Common Shared debris() As debrisType
flareMax = 1000: debrisMax = 5000: debrisStack = 0
Dim flare(flareMax) As flareType
Dim debris(debrisMax) As debrisType
Dim burst As placeType
While 1
rndCycle = Rnd * 30
loopCount = 0
burst.x = .75 * xmax * Rnd + .125 * xmax
burst.y = .5 * ymax * Rnd + .125 * ymax
While loopCount < 7
Cls
'color 14 : locate 0,0: ? debris_stack; " Debris" 'debug line
For i = 1 To 200 'new burst using random old flames to sim burnout
nxt = Int(Rnd * flareMax)
angle = Rnd * _Pi(2)
flare(nxt).x = burst.x + Rnd * 5 * Cos(angle)
flare(nxt).y = burst.y + Rnd * 5 * Sin(angle)
angle = Rnd * _Pi(2)
flare(nxt).dx = Rnd * 15 * Cos(angle)
flare(nxt).dy = Rnd * 15 * Sin(angle)
rc = Int(Rnd * 3)
If rc = 0 Then
flare(nxt).c = _RGB32(255, 100, 0)
ElseIf rc = 1 Then
flare(nxt).c = _RGB32(0, 0, 255)
Else
flare(nxt).c = _RGB32(255, 255, 255)
End If
Next
For i = 0 To flareMax
If flare(i).dy <> 0 Then 'while still moving vertically
Line (flare(i).x, flare(i).y)-Step(flare(i).dx, flare(i).dy), _RGB32(98, 98, 98)
flare(i).x = flare(i).x + flare(i).dx
flare(i).y = flare(i).y + flare(i).dy
Color flare(i).c
Circle (flare(i).x, flare(i).y), 1
flare(i).dy = flare(i).dy + .4 'add gravity
flare(i).dx = flare(i).dx * .95 'add some air resistance
If flare(i).x < 0 Or flare(i).x > xmax Then flare(i).dy = 0 'outside of screen
'add some spark bouncing here
If flare(i).y > ymax Then
If Abs(flare(i).dy) > .5 Then
flare(i).y = ymax: flare(i).dy = flare(i).dy * -.25
Else
flare(i).dy = 0
End If
End If
End If
Next
For i = 0 To debrisStack
PSet (debris(i).x, debris(i).y), debris(i).c
debris(i).x = debris(i).x + Rnd * 3 - 1.5
debris(i).y = debris(i).y + Rnd * 3.5 - 1.5
If debris(i).x < 0 Or debris(i).y < 0 Or debris(i).x > xmax Or debris(i).y > ymax Then NewDebris (i)
Next
_Display
_Limit 20
loopCount = loopCount + 1
Wend
If debrisStack < debrisMax Then
For i = 1 To 20
NewDebris i + debrisStack
Next
debrisStack = debrisStack + 20
End If
Wend
Sub NewDebris (i)
debris(i).x = Rnd * xmax
debris(i).y = Rnd * ymax
c = Rnd * 255
debris(i).c = _RGB32(c, c, c)
End Sub
|
|
|
|
Post by bplus on Jul 4, 2024 20:13:14 GMT
State of the Art (for me)
_Title "Happy Trails 2020" 'from Happy Trails 2018
' 2017-12-29 another redesign of fireworks
' 2017-12-28 redesign fireworks
' now with lake refelction 2017-12-27 forget the bouncing sparks
' combine Welcome Plasma Font with landscape
'_title "Fireworks 3 translation to QB64 2017-12-26 bplus"
'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09
'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris
'fireworks 3.bas try with map variables make bursts around a central point
Randomize Timer
Const xmax = 1200
Const ymax = 720
Const waterline = 600 ' 600 = ratio 5 to 1 sky to water
' raise and lower waterline as desired highest about 400?
Const lTail = 15
Const bluey = 5 * 256 ^ 2 + 256 * 5 + 5
Const debrisMax = 28000
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 120, 20
Type fireWorkType
x As Integer
y As Integer
seed As Integer
age As Integer
life As Integer
End Type
Type debrisType
x As Single
y As Single
c As Long
End Type
Common Shared fw() As fireWorkType
Common Shared debris() As debrisType
Common Shared cN, pR!, pG!, pB!
Screen _NewImage(xmax, ymax, 32)
'prepare message font
mess$ = " Happy New Year 2020"
Print mess$
w = 8 * Len(mess$): h = 16
Dim p(w, h)
black&& = Point(0, 10)
For y = 0 To h
For x = 0 To w
If Point(x, y) <> black&& Then
p(x, y) = 1
End If
Next
Next
xo = 0: yo = 15: m = 7.2
resetPlasma
'prepare landscape
Cls
land& = _NewImage(xmax, ymax, 32)
_Dest land&
drawLandscape
_Dest 0
'prepare fire works
nFW = 3
Dim fw(1 To 10) As fireWorkType
For i = 1 To nFW
initFireWork (i)
Next
''debris feild
'DIM debris(debrisMax) AS debrisType
'OK start the show
While 1
'cls screen with land image
_PutImage , land&, 0
'draw fireworks
For f = 1 To nFW
If fw(f).age <= fw(f).life Then drawfw (f) Else initFireWork f
Next
''debris
'FOR i = 0 TO debrisStack
' PSET (debris(i).x, debris(i).y), debris(i).c
' debris(i).x = debris(i).x + RND * 3 - 1.5
' debris(i).y = debris(i).y + RND * 3.5 - 1.5
' IF debris(i).x < 0 OR debris(i).y < 0 OR debris(i).x > xmax OR debris(i).y > waterline + RND * 20 THEN NewDebris (i)
'NEXT
'text message in plasma
For y = 0 To h - 1
For x = 0 To w - 1
If p(x, y) Then
changePlasma
Else
Color 0
End If
Line (xo + x * m, yo + y * m)-(xo + x * m + m, yo + y * m + m), , BF
Next
Next
lc = lc + 1
If lc Mod 200 = 0 Then resetPlasma
'reflect sky
skyWaterRatio = waterline / (ymax - waterline) - .05
For y = waterline To ymax
For x = 0 To xmax
c&& = Point(x, waterline - ((y - waterline - 1) * skyWaterRatio) + Rnd * 5)
PSet (x, y + 1), c&& + bluey
Next
Next
_Display
_Limit 200 'no limit needed on my system!
''accumulate debris
'IF lc MOD 2000 THEN
' IF debrisStack < debrisMax THEN
' FOR i = 1 TO 2
' NewDebris i + debrisStack
' NEXT
' debrisStack = debrisStack + 2
' END IF
'END IF
Wend
'SUB NewDebris (i)
' debris(i).x = RND * xmax
' debris(i).y = RND * ymax
' c = RND * 155
' debris(i).c = _RGB32(c, c, c)
'END SUB
Sub changePlasma ()
cN = cN + .01
Color _RGB(127 + 127 * Sin(pR! * .3 * cN), 127 + 127 * Sin(pG! * .3 * cN), 127 + 127 * Sin(pB! * .3 * cN))
End Sub
Sub resetPlasma ()
pR! = Rnd ^ 2: pG! = Rnd ^ 2: pB! = Rnd ^ 2
End Sub
Sub drawLandscape
'the sky
For i = 0 To ymax
midInk 0, 0, 0, 78, 28, 68, i / ymax
Line (0, i)-(xmax, i)
Next
'the land
startH = waterline - 80
rr = 10: gg = 20: bb = 15
For mountain = 1 To 6
Xright = 0
y = startH
While Xright < xmax
' upDown = local up / down over range, change along Y
' range = how far up / down, along X
upDown = (Rnd * .8 - .35) * (1 / (1 * mountain))
range = Xright + rand&&(5, 35) * 2.5 / mountain
lastx = Xright - 1
For X = Xright To range
y = y + upDown
Color _RGB32(rr, gg, bb)
Line (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
lastx = X
Next
Xright = range
Wend
rr = rand&&(rr + 5, rr): gg = rand&&(gg + 5, gg): bb = rand&&(bb + 4, bb)
If rr < 0 Then rr = 0
If gg < 0 Then gg = 0
If bb < 0 Then bb = 0
startH = startH + rand&&(1, 10)
Next
'LINE (0, waterline)-(xmax, ymax), _RGB32(0, 0, 0), BF
End Sub
Sub midInk (r1, g1, b1, r2, g2, b2, fr)
Color _RGB(r1 + (r2 - r1) * fr, g1 + (g2 - g1) * fr, b1 + (b2 - b1) * fr)
End Sub
Function rand&& (lo&&, hi&&)
rand&& = Int(Rnd * (hi&& - lo&& + 1)) + lo&&
End Function
Sub drawfw (i)
'here's how to "save" a bunch of random numbers without data and arrays but tons of redundant calculations
Randomize Using fw(i).seed 'this repeats all random numbers generated by seed in same sequence
'recreate our firework from scratch!
red = rand&&(200, 255)
green = rand&&(200, 255)
blue = rand&&(200, 255)
x = rand&&(1, 4)
If x = 1 Then
red = 0
ElseIf x = 2 Then
green = 0
ElseIf x = 3 Then
blue = 0
Else
x = rand&&(1, 4)
If x = 1 Then
red = 0: green = 0
ElseIf x = 2 Then
green = 0: blue = 0
ElseIf x = 3 Then
blue = 0: red = 0
End If
End If
ne = rand&&(80, 300)
Dim embers(ne, 1)
For e = 0 To ne
r = Rnd * 3
embers(e, 0) = r * Cos(e * _Pi(2) / 101)
embers(e, 1) = r * Sin(e * _Pi(2) / 101)
Next
start = fw(i).age - lTail ' don't let tails get longer than lTail const
If start < 1 Then start = 1
For e = 0 To ne
cx = fw(i).x: cy = fw(i).y: dx = embers(e, 0): dy = embers(e, 1)
For t = 1 To fw(i).age
cx = cx + dx
cy = cy + dy
If t >= start Then
'too much like a flower?
midInk 60, 60, 60, red, green, blue, (t - start) / lTail
'midInk 60, 60, 60, 128, 160, 150, (t - start) / lTail
fcirc cx, cy, (t - start) / lTail
End If
dx = dx * .99 'air resitance
dy = dy + .01 'gravity
Next
Color _RGB32(255, 255, 255)
'COLOR _RGB32(red, green, blue)
cx = cx + dx: cy = cy + dy
fcirc cx, cy, (t - start) / lTail
Next
fw(i).age = fw(i).age + 1
End Sub
Sub initFireWork (i)
fw(i).x = rand&&(.1 * xmax, .9 * xmax)
fw(i).y = rand&&(.1 * ymax, .5 * ymax)
fw(i).seed = rand&&(0, 32000)
fw(i).age = 0
fw(i).life = rand&&(20, 120)
End Sub
'Steve McNeil's copied from his forum note: Radius is too common a name
Sub fcirc (CX As Long, CY As Long, R As Long)
Dim subRadius As Long, RadiusError As Long
Dim X As Long, Y As Long
subRadius = Abs(R)
RadiusError = -subRadius
X = subRadius
Y = 0
If subRadius = 0 Then PSet (CX, CY): Exit Sub
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
Line (CX - X, CY)-(CX + X, CY), , BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
Wend
End Sub
|
|
|
|
Post by bplus on Jul 4, 2024 20:14:44 GMT
An ASCII version, use mousewheel to expand and shrink screen:
DefInt A-Z
_Title "ASCII Fireworks !!! Move Mousewheel !!! to Expand or Contract #2" '2020-01-01
' 2020-01-02 update with graivity effect by tsh73 from JB forum
' 2020-08-11 modified for xpanding and contracting screen size
' 2020-08-11 Steve catches memory leak, fixed!
' 2020-08-12 manstersoft gives me idea for Font 8, added more works and switched color to more! RGB32
Const nR = 9, t = " Happy New Year QB64 Forum, ASCII Fireworks Brought To You By Bplus Inspired by Pete, TempodiBasic and Code Hunter Recent Efforts, Gravity Effect by tsh73 at JB Forum, Thanks Steve for saving memory and manstersoft for Font 8 idea, Go In Peace 2020!....."
Type rocket
x As Single
y As Single
bang As Integer
age As Integer
c As _Unsigned Long
End Type
Dim Shared r(1 To nR) As rocket
For i = 1 To nR
new i
Next
Dim Shared fire&
fire& = _NewImage(640, 400, 32)
Dim tmp&(0 To 10)
lastt = 20
sc& = _NewImage(640, 400, 32)
_Font 8
Do
_Dest fire&
_Font 16
Cls
Color &HFFFF88AA
lc = lc + 1
If lc Mod 3 = 0 Then p = (p + 1) Mod Len(t)
Locate 2, 20: Print Mid$(t, p + 1, 40);
_Font 8
rocs = rocs + 1
If rocs > nR Then rocs = nR
For i = 1 To rocs
drawRocket i
Next
_Dest 0
While _MouseInput
scroll = scroll + _MouseWheel
Wend
If scroll < 800 And scroll > -400 Then
tp = (tp + 1) Mod 10
tmp&(tp) = _NewImage(640 + scroll, 400 + scroll, 32)
Screen tmp&(tp)
_PutImage , fire&, 0
Else
lastt = 20
End If
'debug
'COLOR qb(15)
'LOCATE 1, 1: PRINT lastt, tp, scroll
If lastt <> 20 Then _FreeImage tmp&(lastt)
lastt = tp
_Display
_Limit 20
Loop Until _KeyDown(27)
Sub new (i)
r(i).x = Rnd * 60 + 10
r(i).y = 50
r(i).bang = Rnd * 30
r(i).age = 0
r(i).c = _RGB32(200 * Rnd + 55, 200 * Rnd + 55, 200 * Rnd + 55)
End Sub
Sub drawRocket (i)
If r(i).y > r(i).bang Then
Color r(i).c
Locate r(i).y, r(i).x: Print Chr$(24);
r(i).y = r(i).y - 1
Else
r(i).age = r(i).age + 1
If r(i).age > 50 Then
new i
Else
Color r(i).c
If r(i).age > 4 Then start = r(i).age - 4 Else start = 1
For a = start To r(i).age
For j = 1 To 12
xx = r(i).x + 1 * a * Cos(j * _Pi / 6)
yy = r(i).y + .5 * a * Sin(j * _Pi / 6)
yy = yy + (r(i).y - a) ^ 2 / 15 '<<<< tsh73 gravity
If xx > 0 And xx < 81 And yy > 0 And yy < 51 Then
Locate Int(yy), Int(xx)
Print "*";
End If
Next
Next
End If
End If
End Sub
|
|
Aaditya Parashar
Full Member
Just somebody with an abnormal coding routine.
Posts: 124
|
Post by Aaditya Parashar on Jul 5, 2024 3:19:19 GMT
What if someone projected this on a new year's eve? I think it would look cool.  |
|
|
|
Post by bplus on Jul 5, 2024 14:46:22 GMT
Thanks AP, projected where, into sky?
All these would be improved by some explosion sounds.
|
|
ubi44
Junior Member
Posts: 51
|
Post by ubi44 on Jul 8, 2024 12:34:45 GMT
Nice !
here's my attempt about fireworks...
Screen _NewImage(600 * 16 / 9, 600, 32)
Type artifice
P As _Float
Vx As _Float
Vy As _Float
pX As _Float
pY As _Float
r As Single
g As Single
b As Single
End Type
ReDim Shared NBArtif, NBPArtif
NBPArtif = 350
NBArtif = 7
ReDim Shared maxCercle
maxCercle = _Height / 5
ReDim Shared Artif(NBArtif, NBPArtif) As artifice
ReDim Shared ActiF(NBArtif)
ReDim Shared maCv(maxCercle, maxCercle * 2, maxCercle * 2) As Single
precalcus
FPS = 60
before = Timer + 1
Type vec3
x As Single
y As Single
z As Single
End Type
ReDim Shared Letoil As vec3
Letoil.x = -2
Letoil.y = -0.1
Letoil.z = -4
ReDim Shared NBr, NBPackEtoile, NBEtoileShow
NBPackEtoile = 100
NBEtoileShow = 20
ReDim Shared diamEtoile
diamEtoile = HIGH / 150
Type etoile
x As Single
y As Single
z As Single
r As Single
g As Single
b As Single
vit As Integer
diam As _Float
dx As _Float
dy As _Float
End Type
NBr = 14
ReDim Shared E(NBPackEtoile, NBr + NBr * NBr) As etoile
Do
Etoiles FPS * 10, 10
_Title "FireWorks by ubi44 _/ FPS:" + Str$(FPS)
For i = 0 To NBArtif
If ActiF(i) = 0 And gotime < Timer(.01) Then
mfx = _Width / 2 + (Rnd - Rnd) * (_Width / 3)
mfy = (_Height / 1.2) - _Height / 6.5 - (Rnd) * (_Height / 5)
initARTIF i, mfx, mfy
gotime = Timer(.01) + .1 + Rnd * .2
End If
Next i
For i = 0 To NBArtif
If ActiF(i) = 1 Then updateArtif i, FPS
Next i
_Limit FPS
totfps = totfps + 1
If before < Timer Then
before = Timer + 1
FPS = totfps
totfps = 0
End If
_Display
Cls
Loop Until _KeyDown(27)
Sub updateArtif (i, tfps)
HIGH = _Height
If tfps < 10 Then tfps = 10
hp = Rnd
tic = 0
If hp < .1 Then tic = 1
If hp > .9 Then tic = 2
For j = 0 To NBPArtif
Select Case Artif(i, j).P
Case Is <= 0
Artif(i, j).P = 0
Artif(i, j).Vx = 0
Artif(i, j).Vy = 0
Artif(i, j).pX = 0
Artif(i, j).pY = 0
Case Is > .5
Artif(i, j).P = Artif(i, j).P - (.3 + .3 * Rnd) / tfps
Artif(i, j).Vy = Artif(i, j).Vy + (1.2 / tfps)
Artif(i, j).pX = Artif(i, j).pX + Artif(i, j).Vx * ((600) / tfps) * (HIGH / 1080)
Artif(i, j).pY = Artif(i, j).pY + Artif(i, j).Vy * ((600) / tfps) * (HIGH / 1080)
If tic = 0 Then
If Artif(i, j).P < .5 Then
Artif(i, j).Vy = Cos(j + Timer(.0001))
Artif(i, j).Vx = Sin(j + Timer(.0001))
Artif(i, j).P = .1 + Rnd * .39
End If
End If
If tic = 1 Then
If Artif(i, j).P < .5 Then
Artif(i, j).Vy = (-Rnd)
Artif(i, j).Vx = (Rnd - Rnd)
Artif(i, j).P = .1 + Rnd * .39
End If
End If
If tic = 2 Then
If Artif(i, j).P < .5 Then
Artif(i, j).Vy = Cos(j * _Pi + Timer)
Artif(i, j).Vx = Sin(j * _Pi + Timer)
Artif(i, j).P = .1 + Rnd * .39
End If
End If
If j = Int(NBPArtif / 2) Then
hr = Artif(i, j).r + (1 - Artif(i, j).P) * 228
hg = Artif(i, j).g + (1 - Artif(i, j).P) * 228
hb = Artif(i, j).b + (1 - Artif(i, j).P) * 228
cercleSUN3 Artif(i, j).pX, Artif(i, j).pY, (1 - Artif(i, j).P) * (HIGH / 50), (1 - Artif(i, j).P) * 128, hr, hg, hb, 2, 4
End If
Case Is < .5
Artif(i, j).P = Artif(i, j).P - ((_Height - Artif(i, j).pY) / _Height) * ((.65 + .55 * Rnd) / tfps)
Artif(i, j).Vy = Artif(i, j).Vy + (.5 - Artif(i, j).P) * (Artif(i, j).pY / _Height) * (5 / tfps)
Artif(i, j).pX = Artif(i, j).pX + Artif(i, j).Vx * (.015 - Rnd * .01 + Artif(i, j).P / 5) * (6000 / tfps) * (HIGH / 1080)
Artif(i, j).pY = Artif(i, j).pY + Artif(i, j).Vy * (.015 - Rnd * .01 + Artif(i, j).P / 5) * (6000 / tfps) * (HIGH / 1080)
cl = Artif(i, j).P * 255 * (1.5 - (Artif(i, j).pY / _Height))
hr = Artif(i, j).r + (1 - Artif(i, j).P) * 228
hg = Artif(i, j).g + (1 - Artif(i, j).P) * 228
hb = Artif(i, j).b + (1 - Artif(i, j).P) * 228
cercleSUN3 Artif(i, j).pX, Artif(i, j).pY, (1 - Artif(i, j).P) * (HIGH / 28), cl * .75, hr, hg, hb, 2, 4
If hr > hg And hr > hb Then cr = 255 Else cr = 0
If hg > hb And hg > hr Then cg = 255 Else cg = 0
If hb > hg And hb > hr Then cb = 255 Else cb = 0
cercleSUN3 Artif(i, j).pX, Artif(i, j).pY, (1 - Artif(i, j).P) * (HIGH / 72), cl * 2, cr, cg, cb, 1, 2
PSet (Artif(i, j).pX, Artif(i, j).pY), _RGBA(255, 255, 255, Artif(i, j).P * (355))
Circle (Artif(i, j).pX, Artif(i, j).pY), .5, _RGBA(255, 255, 255, Artif(i, j).P * (255))
End Select
Next j
q = 0
For j = 0 To NBPArtif
If Artif(i, j).P = 0 Or Artif(i, j).pX < 0 Or Artif(i, j).pX > _Width Or Artif(i, j).pY < 0 Or Artif(i, j).pY > _Height Then q = q + 1
Next j
If j = q Then ActiF(i) = 0
End Sub
Sub initARTIF (I, x, y)
pot = Sgn(Rnd - Rnd) * .5 * (Rnd * .5 + .5)
rr = Rnd * 155
gg = Rnd * 155
bb = Rnd * 155
For j = 0 To NBPArtif - Rnd * 150
Artif(I, j).P = 1
Artif(I, j).Vx = (pot * .1)
Artif(I, j).Vy = (-.9 - .05 * Rnd * (j / NBPArtif))
Artif(I, j).pX = x
Artif(I, j).pY = y
Artif(I, j).r = rr
Artif(I, j).g = gg
Artif(I, j).b = bb
Next j
ActiF(I) = 1
End Sub
Sub cercleSUN3 (afx, afy, r, Kalpha, hr, hg, hb, ut1, ut2)
Static ut
If ut = 0 Then ut = ut1
For aa = 0 To r * 2 Step ut
For bb = 0 To r * 2 Step ut
cl = (maCv(r, aa, bb))
i% = aa - r
j% = bb - r
alpha = cl
If cl > .3 Then PSet (afx + i%, afy + j%), _RGBA(cl * hr, cl * hg, cl * hb, Kalpha * alpha)
Next bb
Next aa
If ut = ut2 Then ut = ut1 Else ut = ut2
End Sub
Sub precalcus
For r = 0 To maxCercle
diam = (r * r + r * r)
a = 0: b = 0
For i% = -r To r
For j% = -r To r
maCv(r, a, b) = 1 - (Sqr((i% * i%) + (j% * j%)) / r)
b = b + 1
Next j%
b = 0: a = a + 1
Next i%
Next r
End Sub
Sub Etoiles (globe, bifx)
Static oldGFPS
If globe < 10 Then cGFPS = 10 Else cGFPS = globe
vitesse = NBr / ((1 + cGFPS * 15) * 2)
HIGH = _Height
oldGFPS = cGFPS
Letoil.z = -(_Height / 2) / _Height * bifx * .25
Letoil.x = -(_Width / 2) / _Width * bifx * 1.25
CSx = Cos(.053 * Letoil.x / 55)
SNx = Sin(.053 * Letoil.x / 55)
CTx = Cos(.053 * Letoil.z / 55)
STx = Sin(.053 * Letoil.z / 55)
For xx = 0 To NBr
For yy = 0 To NBr
For q = 0 To NBEtoileShow
tut = xx + xx * yy
vitesse = NBr / ((1 + cGFPS) * E(q, tut).vit) * 30
ptx = E(q, tut).x + E(q, tut).dx
pty = E(q, tut).y + E(q, tut).dy
E(q, tut).dx = E(q, tut).dx * (.995 + Rnd * .005)
E(q, tut).dy = E(q, tut).dy * (.995 + Rnd * .005)
ptz = E(q, tut).z
E(q, tut).x = ptx + Letoil.x * vitesse * (.02 / (bifx * .5)) * Cos((1 - (ptz / NBr)) * _Pi * NBr)
E(q, tut).y = pty + Letoil.z * vitesse * (.02 / (bifx * .5)) * Sin((1 - (ptz / NBr)) * _Pi * NBr)
E(q, tut).z = ptz - (vitesse + .02) / (E(q, tut).diam)
afx = (_Width / 2 + (47 + 88) * (ptx + Letoil.x * .5) / ptz * (4 + 1))
If (afx > 0) And afx < _Width And ptz > 0 Then
afy = (_Height / 2 + (47 + 78) * (pty) / ptz * (4 + 1))
If afy > 0 And afy < _Height Then
r = (1 - (ptz / NBr)) * E(q, tut).diam * .25
If E(q, tut).diam >= (HIGH / 180) + .9 * diamEtoile * 4 Then r = r * 1.5
cr = (1 - (ptz / (NBr * 2))) * 150
If r * HIGH / 450 >= 6 Then cerclefumee afx, afy, r * HIGH / 255, cr * 8, 6, 8, 1.9, E(q, tut).r, E(q, tut).g / 2, E(q, tut).b / 1.5
If r > 2 Then
cercle afx - r * .5, afy - r * .5, r * .75, E(q, tut).r * .75, E(q, tut).g * .75, E(q, tut).b * .75, (1 - (ptz / (NBr * 2))) * .6 + .2, 4, 6
End If
PSet (afx, afy), _RGBA(185 + 255 * E(q, tut).b * ((ptz / NBr)), 158 + 255 * E(q, tut).r * ((ptz / NBr)), 158 + 255 * E(q, tut).g * ((ptz / NBr)), HIGH * .28 * (1 - (ptz / NBr)) * (E(q, tut).diam / ((HIGH / 180) + diamEtoile * 4)))
PSet (afx, afy), _RGBA(255 - E(q, tut).b * 180, 255 - E(q, tut).b * 200, 255 - E(q, tut).b * 255, HIGH * .08 * (1 - (ptz / NBr)) * (E(q, tut).diam / ((HIGH / 180) + diamEtoile * 2)))
pitet = pitet + 1
Else
If (afx < -_Width) Or afx > _Width * 2 Or ptz < -NBr Then
E(q, tut).x = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).y = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).z = (NBr)
E(q, tut).diam = (1080 / 180) + Rnd * diamEtoile * 4
E(q, tut).r = Rnd * .813 + .03
E(q, tut).g = Rnd * .803 + .03
E(q, tut).b = Rnd * .803 + .03
E(q, tut).vit = 10 + Rnd * 30
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b Then
If Rnd < .5 Then
E(q, tut).r = E(q, tut).g * (1 + Rnd * .1)
Else
E(q, tut).r = (30 + Rnd * 25) / 655
E(q, tut).g = (92 + Rnd * 60) / 655
E(q, tut).b = (193 - Rnd * 60) / 655
End If
End If
E(q, tut).dx = (Rnd - Rnd) * (.05 + Rnd * .025)
E(q, tut).dy = (Rnd - Rnd) * (.05 + Rnd * .025)
If Rnd > .8 Then
If E(q, tut).r > E(q, tut).g And E(q, tut).r > E(q, tut).b Then
E(q, tut).r = .82: E(q, tut).g = E(q, tut).r * Rnd
E(q, tut).b = 0
GoTo ppp
End If
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b Then
E(q, tut).g = .82
If Rnd > .5 Then E(q, tut).b = E(q, tut).g * Rnd Else E(q, tut).r = E(q, tut).g * (1 + Rnd)
If Rnd > .95 Then E(q, tut).r = 0: E(q, tut).b = E(q, tut).b * .1
GoTo ppp
End If
If E(q, tut).b > E(q, tut).r And E(q, tut).b > E(q, tut).g Then
E(q, tut).b = .82
E(q, tut).g = E(q, tut).b * Rnd
E(q, tut).r = 0
End If
End If
ppp:
End If
End If
Else
If afy < -_Height Or afy > _Height * 2 Or ptz < 0 Then
E(q, tut).x = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).y = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).z = (NBr)
E(q, tut).diam = (1080 / 180) + Rnd * diamEtoile * 4
E(q, tut).r = Rnd * .8125
E(q, tut).g = Rnd * .8125
E(q, tut).b = Rnd * .8125
If E(q, tut).b > E(q, tut).r Then
E(q, tut).r = (30 + Rnd * 25) / 655
E(q, tut).g = (92 + Rnd * 60) / 655
E(q, tut).b = (193 - Rnd * 60) / 655
Else
E(q, tut).g = E(q, tut).g + E(q, tut).b
E(q, tut).r = E(q, tut).r * .2
End If
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b And Rnd < .5 Then E(q, tut).r = E(q, tut).g * (1 + Rnd * .1)
E(q, tut).vit = 10 + Rnd * 30
E(q, tut).dx = (Rnd - Rnd) * (.05 + Rnd * .025)
E(q, tut).dy = (Rnd - Rnd) * (.05 + Rnd * .025)
If Rnd > .8 Then
If E(q, tut).r > E(q, tut).g And E(q, tut).r > E(q, tut).b Then
E(q, tut).r = .82: E(q, tut).g = E(q, tut).r * Rnd
E(q, tut).b = 0
GoTo ppp
End If
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b Then
E(q, tut).g = .82
If Rnd > .5 Then E(q, tut).b = E(q, tut).g * Rnd Else E(q, tut).r = E(q, tut).g * (1 + Rnd)
If Rnd > .95 Then E(q, tut).r = 0: E(q, tut).b = E(q, tut).b * .1
GoTo ppp2
End If
If E(q, tut).b > E(q, tut).r And E(q, tut).b > E(q, tut).g Then
E(q, tut).b = .82
E(q, tut).g = E(q, tut).b * Rnd
E(q, tut).r = 0
End If
End If
ppp2:
End If
End If
Next
Next yy
Next xx
End Sub
Sub cerclefumee (afx, afy, r, cr, ut1, ut2, aaa, hr, hg, hb)
Static ut
If ut = 0 Then ut = ut1
For aa = 0 To r * 2 Step ut
For bb = 0 To r * 2 Step ut
cl = (maCv(r, aa, bb))
i% = aa - r
j% = bb - r
alpha = cl * aaa
PSet (afx + i%, afy + j%), _RGBA((hr * 100) * alpha, (100 * hg) * alpha, (100 * hb) * alpha, cr * alpha)
Next bb, aa
If ut = ut2 Then ut = ut1 Else ut = ut2
End Sub
Sub cercle (afx, afy, r, hr, hg, hb, aaa, ut1, ut2)
Static ut
If ut = 0 Then ut = ut1
For aa = 0 To r * 2 Step ut
For bb = 0 To r * 2 Step ut
cl = (maCv(r, aa, bb)) * 1.3
i% = aa - r
j% = bb - r
alpha = cl * 2
Line (afx + i%, afy + j%)-(afx + i% + ut, afy + j% + ut), _RGBA((cl * 128 * hr), (cl * 128 * hg), (cl * 128 * hb), 150 * alpha * aaa), BF
Next bb
Next aa
If ut = ut2 Then ut = ut1 Else ut = ut2
End Sub
|
|
|
|
Post by bplus on Jul 8, 2024 13:18:48 GMT
Nice fumes/atmosphere blend!
|
|
ubi44
Junior Member
Posts: 51
|
Post by ubi44 on Jul 8, 2024 17:59:50 GMT
Small update to respect the title of the post! so I reused the message "happy new years" made from the post above but I don't use change and resetplasma ... I also (tried) to put more color in the fireworks!
Screen _NewImage(600 * 16 / 9, 600, 32)
Type artifice
P As _Float
Vx As _Float
Vy As _Float
pX As _Float
pY As _Float
r As Single
g As Single
b As Single
End Type
ReDim Shared NBArtif, NBPArtif
NBPArtif = 350
NBArtif = 7
ReDim Shared maxCercle
maxCercle = _Height / 5
'prepare message font
mess$ = " Happy New Year 2024"
Print mess$
w = 8 * Len(mess$): h = 16
Dim p(w, h)
black&& = Point(0, 10)
For y = 0 To h
For x = 0 To w
If Point(x, y) <> black&& Then
p(x, y) = 1
End If
Next
Next
xo = 0: yo = 45: m = 6
ReDim Shared Artif(NBArtif, NBPArtif) As artifice
ReDim Shared ActiF(NBArtif)
ReDim Shared maCv(maxCercle, maxCercle * 2, maxCercle * 2) As Single
precalcus
FPS = 60
before = Timer + 1
Type vec3
x As Single
y As Single
z As Single
End Type
ReDim Shared Letoil As vec3
Letoil.x = -2
Letoil.y = -0.1
Letoil.z = -4
ReDim Shared NBr, NBPackEtoile, NBEtoileShow
NBPackEtoile = 100
NBEtoileShow = 20
ReDim Shared diamEtoile
diamEtoile = HIGH / 150
Type etoile
x As Single
y As Single
z As Single
r As Single
g As Single
b As Single
vit As Integer
diam As _Float
dx As _Float
dy As _Float
End Type
NBr = 14
ReDim Shared E(NBPackEtoile, NBr + NBr * NBr) As etoile
Do
Etoiles FPS * 10, 10
_Title "FireWorks by ubi44 _/ FPS:" + Str$(FPS)
For y = 0 To h - 1
For x = 0 To w - 1
If p(x, y) Then
yoo = yo + Sin(((((x + Rush) Mod w) / w) * _Pi * 2)) * m * 5
Rush = Rush + FPS * .0001
If Rush > w Then Rush = 0
R = 175 + (Sin(((((x + Rush * .1) Mod w) / w) * _Pi * 2)) * 75)
g = 175 + (Sin(((((y + Rush * .1) Mod h) / h) * _Pi * 2)) * 75)
b = 175 + (Cos(((((x + Rush * .1) Mod w) / w) * _Pi * 2)) * 75)
Line (xoo + x * m, yoo + y * m)-(xoo + x * m + m - 2, yoo + y * m + m - 2), _RGBA(R, g, b, 128), BF
End If
Next
Next
For i = 0 To NBArtif
If ActiF(i) = 0 And gotime < Timer(.01) Then
mfx = _Width / 2 + (Rnd - Rnd) * (_Width / 3)
mfy = (_Height / 1.2) - _Height / 6.5 - (Rnd) * (_Height / 5)
initARTIF i, mfx, mfy
gotime = Timer(.01) + .1 + Rnd * .2
End If
Next i
For i = 0 To NBArtif
If ActiF(i) = 1 Then updateArtif i, FPS
Next i
_Limit FPS
totfps = totfps + 1
If before < Timer Then
before = Timer + 1
FPS = totfps
totfps = 0
End If
_Display
Cls
Loop Until _KeyDown(27)
Sub updateArtif (i, tfps)
HIGH = _Height
If tfps < 10 Then tfps = 10
hp = Rnd
tic = 0
If hp < .1 Then tic = 1
If hp > .9 Then tic = 2
For j = 0 To NBPArtif
Select Case Artif(i, j).P
Case Is <= 0
Artif(i, j).P = 0
Artif(i, j).Vx = 0
Artif(i, j).Vy = 0
Artif(i, j).pX = 0
Artif(i, j).pY = 0
Case Is > .5
Artif(i, j).P = Artif(i, j).P - (.3 + .3 * Rnd) / tfps
Artif(i, j).Vy = Artif(i, j).Vy + (1.2 / tfps)
Artif(i, j).pX = Artif(i, j).pX + Artif(i, j).Vx * ((600) / tfps) * (HIGH / 1080)
Artif(i, j).pY = Artif(i, j).pY + Artif(i, j).Vy * ((600) / tfps) * (HIGH / 1080)
If tic = 0 Then
If Artif(i, j).P < .5 Then
Artif(i, j).Vy = Cos(j + Timer(.0001))
Artif(i, j).Vx = Sin(j + Timer(.0001))
Artif(i, j).P = .1 + Rnd * .39
End If
End If
If tic = 1 Then
If Artif(i, j).P < .5 Then
Artif(i, j).Vy = (-Rnd)
Artif(i, j).Vx = (Rnd - Rnd)
Artif(i, j).P = .1 + Rnd * .39
End If
End If
If tic = 2 Then
If Artif(i, j).P < .5 Then
Artif(i, j).Vy = Cos(j * _Pi + Timer)
Artif(i, j).Vx = Sin(j * _Pi + Timer)
Artif(i, j).P = .1 + Rnd * .39
End If
End If
If j = Int(NBPArtif / 2) Then
hr = Artif(i, j).r + (1 - Artif(i, j).P) * 228
hg = Artif(i, j).g + (1 - Artif(i, j).P) * 228
hb = Artif(i, j).b + (1 - Artif(i, j).P) * 228
cercleSUN3 Artif(i, j).pX, Artif(i, j).pY, (1 - Artif(i, j).P) * (HIGH / 50), (1 - Artif(i, j).P) * 128, hr, hg, hb, 2, 4
End If
Case Is < .5
PSet (Artif(i, j).pX, Artif(i, j).pY), _RGBA(255, 255, 255, (.2 + Artif(i, j).P) * (255))
Artif(i, j).P = Artif(i, j).P - ((_Height - Artif(i, j).pY) / _Height) * ((.65 + .55 * Rnd) / tfps)
Artif(i, j).Vy = Artif(i, j).Vy + (.5 - Artif(i, j).P) * (Artif(i, j).pY / _Height) * (5 / tfps)
Artif(i, j).pX = Artif(i, j).pX + Artif(i, j).Vx * (.015 - Rnd * .01 + Artif(i, j).P / 5) * (6000 / tfps) * (HIGH / 1080)
Artif(i, j).pY = Artif(i, j).pY + Artif(i, j).Vy * (.015 - Rnd * .01 + Artif(i, j).P / 5) * (6000 / tfps) * (HIGH / 1080)
cl = Artif(i, j).P * 255 * (1.5 - (Artif(i, j).pY / _Height))
hr = Artif(i, j).r + (1 - Artif(i, j).P) * 228
hg = Artif(i, j).g + (1 - Artif(i, j).P) * 228
hb = Artif(i, j).b + (1 - Artif(i, j).P) * 228
cercleSUN3 Artif(i, j).pX, Artif(i, j).pY, (1 - Artif(i, j).P) * (HIGH / 28), cl * .75, hr, hg, hb, 2, 4
If hr > hg And hr > hb Then cr = 255 Else cr = 0
If hg > hb And hg > hr Then cg = 255 Else cg = 0
If hb > hg And hb > hr Then cb = 255 Else cb = 0
Circle (Artif(i, j).pX, Artif(i, j).pY), .5, _RGBA(255, 255, 255, (Artif(i, j).P) * (155))
cercleSUN3 Artif(i, j).pX, Artif(i, j).pY, (1 - Artif(i, j).P) * (HIGH / 42), cl * 2, cr, cg, cb, 1, 2
End Select
Next j
q = 0
For j = 0 To NBPArtif
If Artif(i, j).P = 0 Or Artif(i, j).pX < 0 Or Artif(i, j).pX > _Width Or Artif(i, j).pY < 0 Or Artif(i, j).pY > _Height Then q = q + 1
Next j
If j = q Then ActiF(i) = 0
End Sub
Sub initARTIF (I, x, y)
pot = Sgn(Rnd - Rnd) * .5 * (Rnd * .5 + .5)
rr = Rnd * 155
gg = Rnd * 155
bb = Rnd * 155
For j = 0 To NBPArtif - Rnd * 150
Artif(I, j).P = 1
Artif(I, j).Vx = (pot * .1)
Artif(I, j).Vy = (-.9 - .05 * Rnd * (j / NBPArtif))
Artif(I, j).pX = x
Artif(I, j).pY = y
Artif(I, j).r = rr
Artif(I, j).g = gg
Artif(I, j).b = bb
Next j
ActiF(I) = 1
End Sub
Sub cercleSUN3 (afx, afy, r, Kalpha, hr, hg, hb, ut1, ut2)
Static ut
If ut = 0 Then ut = ut1
For aa = 0 To r * 2 Step ut
For bb = 0 To r * 2 Step ut
cl = (maCv(r, aa, bb))
i% = aa - r
j% = bb - r
alpha = cl
If cl > .3 Then PSet (afx + i%, afy + j%), _RGBA(cl * hr, cl * hg, cl * hb, Kalpha * alpha)
Next bb
Next aa
If ut = ut2 Then ut = ut1 Else ut = ut2
End Sub
Sub precalcus
For r = 0 To maxCercle
diam = (r * r + r * r)
a = 0: b = 0
For i% = -r To r
For j% = -r To r
maCv(r, a, b) = 1 - (Sqr((i% * i%) + (j% * j%)) / r)
b = b + 1
Next j%
b = 0: a = a + 1
Next i%
Next r
End Sub
Sub Etoiles (globe, bifx)
Static oldGFPS
If globe < 10 Then cGFPS = 10 Else cGFPS = globe
vitesse = NBr / ((1 + cGFPS * 15) * 2)
HIGH = _Height
oldGFPS = cGFPS
Letoil.z = -(_Height / 2) / _Height * bifx * .25
Letoil.x = -(_Width / 2) / _Width * bifx * 1.25
CSx = Cos(.053 * Letoil.x / 55)
SNx = Sin(.053 * Letoil.x / 55)
CTx = Cos(.053 * Letoil.z / 55)
STx = Sin(.053 * Letoil.z / 55)
For xx = 0 To NBr
For yy = 0 To NBr
For q = 0 To NBEtoileShow
tut = xx + xx * yy
vitesse = NBr / ((1 + cGFPS) * E(q, tut).vit) * 30
ptx = E(q, tut).x + E(q, tut).dx
pty = E(q, tut).y + E(q, tut).dy
E(q, tut).dx = E(q, tut).dx * (.995 + Rnd * .005)
E(q, tut).dy = E(q, tut).dy * (.995 + Rnd * .005)
ptz = E(q, tut).z
E(q, tut).x = ptx + Letoil.x * vitesse * (.02 / (bifx * .5)) * Cos((1 - (ptz / NBr)) * _Pi * NBr)
E(q, tut).y = pty + Letoil.z * vitesse * (.02 / (bifx * .5)) * Sin((1 - (ptz / NBr)) * _Pi * NBr)
E(q, tut).z = ptz - (vitesse + .02) / (E(q, tut).diam)
afx = (_Width / 2 + (47 + 88) * (ptx + Letoil.x * .5) / ptz * (4 + 1))
If (afx > 0) And afx < _Width And ptz > 0 Then
afy = (_Height / 2 + (47 + 78) * (pty) / ptz * (4 + 1))
If afy > 0 And afy < _Height Then
r = (1 - (ptz / NBr)) * E(q, tut).diam * .25
If E(q, tut).diam >= (HIGH / 180) + .9 * diamEtoile * 4 Then r = r * 1.5
cr = (1 - (ptz / (NBr * 2))) * 150
If r * HIGH / 450 >= 6 Then cerclefumee afx, afy, r * HIGH / 255, cr * 8, 6, 8, 1.9, E(q, tut).r, E(q, tut).g / 2, E(q, tut).b / 1.5
If r > 2 Then
cercle afx - r * .5, afy - r * .5, r * .75, E(q, tut).r * .75, E(q, tut).g * .75, E(q, tut).b * .75, (1 - (ptz / (NBr * 2))) * .6 + .2, 4, 6
End If
PSet (afx, afy), _RGBA(185 + 255 * E(q, tut).b * ((ptz / NBr)), 158 + 255 * E(q, tut).r * ((ptz / NBr)), 158 + 255 * E(q, tut).g * ((ptz / NBr)), HIGH * .28 * (1 - (ptz / NBr)) * (E(q, tut).diam / ((HIGH / 180) + diamEtoile * 4)))
PSet (afx, afy), _RGBA(255 - E(q, tut).b * 180, 255 - E(q, tut).b * 200, 255 - E(q, tut).b * 255, HIGH * .08 * (1 - (ptz / NBr)) * (E(q, tut).diam / ((HIGH / 180) + diamEtoile * 2)))
pitet = pitet + 1
Else
If (afx < -_Width) Or afx > _Width * 2 Or ptz < -NBr Then
E(q, tut).x = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).y = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).z = (NBr)
E(q, tut).diam = (1080 / 180) + Rnd * diamEtoile * 4
E(q, tut).r = Rnd * .813 + .03
E(q, tut).g = Rnd * .803 + .03
E(q, tut).b = Rnd * .803 + .03
E(q, tut).vit = 10 + Rnd * 30
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b Then
If Rnd < .5 Then
E(q, tut).r = E(q, tut).g * (1 + Rnd * .1)
Else
E(q, tut).r = (30 + Rnd * 25) / 655
E(q, tut).g = (92 + Rnd * 60) / 655
E(q, tut).b = (193 - Rnd * 60) / 655
End If
End If
E(q, tut).dx = (Rnd - Rnd) * (.05 + Rnd * .025)
E(q, tut).dy = (Rnd - Rnd) * (.05 + Rnd * .025)
If Rnd > .8 Then
If E(q, tut).r > E(q, tut).g And E(q, tut).r > E(q, tut).b Then
E(q, tut).r = .82: E(q, tut).g = E(q, tut).r * Rnd
E(q, tut).b = 0
GoTo ppp
End If
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b Then
E(q, tut).g = .82
If Rnd > .5 Then E(q, tut).b = E(q, tut).g * Rnd Else E(q, tut).r = E(q, tut).g * (1 + Rnd)
If Rnd > .95 Then E(q, tut).r = 0: E(q, tut).b = E(q, tut).b * .1
GoTo ppp
End If
If E(q, tut).b > E(q, tut).r And E(q, tut).b > E(q, tut).g Then
E(q, tut).b = .82
E(q, tut).g = E(q, tut).b * Rnd
E(q, tut).r = 0
End If
End If
ppp:
End If
End If
Else
If afy < -_Height Or afy > _Height * 2 Or ptz < 0 Then
E(q, tut).x = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).y = Rnd * (NBr) * Sgn(Cos(Rnd * 360))
E(q, tut).z = (NBr)
E(q, tut).diam = (1080 / 180) + Rnd * diamEtoile * 4
E(q, tut).r = Rnd * .8125
E(q, tut).g = Rnd * .8125
E(q, tut).b = Rnd * .8125
If E(q, tut).b > E(q, tut).r Then
E(q, tut).r = (30 + Rnd * 25) / 655
E(q, tut).g = (92 + Rnd * 60) / 655
E(q, tut).b = (193 - Rnd * 60) / 655
Else
E(q, tut).g = E(q, tut).g + E(q, tut).b
E(q, tut).r = E(q, tut).r * .2
End If
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b And Rnd < .5 Then E(q, tut).r = E(q, tut).g * (1 + Rnd * .1)
E(q, tut).vit = 10 + Rnd * 30
E(q, tut).dx = (Rnd - Rnd) * (.05 + Rnd * .025)
E(q, tut).dy = (Rnd - Rnd) * (.05 + Rnd * .025)
If Rnd > .8 Then
If E(q, tut).r > E(q, tut).g And E(q, tut).r > E(q, tut).b Then
E(q, tut).r = .82: E(q, tut).g = E(q, tut).r * Rnd
E(q, tut).b = 0
GoTo ppp
End If
If E(q, tut).g > E(q, tut).r And E(q, tut).g > E(q, tut).b Then
E(q, tut).g = .82
If Rnd > .5 Then E(q, tut).b = E(q, tut).g * Rnd Else E(q, tut).r = E(q, tut).g * (1 + Rnd)
If Rnd > .95 Then E(q, tut).r = 0: E(q, tut).b = E(q, tut).b * .1
GoTo ppp2
End If
If E(q, tut).b > E(q, tut).r And E(q, tut).b > E(q, tut).g Then
E(q, tut).b = .82
E(q, tut).g = E(q, tut).b * Rnd
E(q, tut).r = 0
End If
End If
ppp2:
End If
End If
Next
Next yy
Next xx
End Sub
Sub cerclefumee (afx, afy, r, cr, ut1, ut2, aaa, hr, hg, hb)
Static ut
If ut = 0 Then ut = ut1
For aa = 0 To r * 2 Step ut
For bb = 0 To r * 2 Step ut
cl = (maCv(r, aa, bb))
i% = aa - r
j% = bb - r
alpha = cl * aaa
PSet (afx + i%, afy + j%), _RGBA((hr * 100) * alpha, (100 * hg) * alpha, (100 * hb) * alpha, cr * alpha)
Next bb, aa
If ut = ut2 Then ut = ut1 Else ut = ut2
End Sub
Sub cercle (afx, afy, r, hr, hg, hb, aaa, ut1, ut2)
Static ut
If ut = 0 Then ut = ut1
For aa = 0 To r * 2 Step ut
For bb = 0 To r * 2 Step ut
cl = (maCv(r, aa, bb)) * 1.3
i% = aa - r
j% = bb - r
alpha = cl * 2
Line (afx + i%, afy + j%)-(afx + i% + ut, afy + j% + ut), _RGBA((cl * 128 * hr), (cl * 128 * hg), (cl * 128 * hb), 150 * alpha * aaa), BF
Next bb
Next aa
If ut = ut2 Then ut = ut1 Else ut = ut2
End Sub
|
|
|
|
Post by bplus on Jul 8, 2024 19:27:39 GMT
nice wavey banner!
|
|
