+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: Exploding Ascii Diamonds (/showthread.php?tid=4116)
Exploding Ascii Diamonds - bplus - 11-16-2025
Pure Screen 0 for @Pete and @AsciiHole
Code: (Select All)
_Title "Exploding Ascii Diamonds" 'b+ 2025-11-15
' from PM conversations with AsciiHole
Randomize Timer
_FullScreen
Type Diamond
As Integer xc, yc, c, life, active
End Type
Const NDiamonds = 5
Dim Shared D(1 To NDiamonds) As Diamond
For i = 1 To NDiamonds ' initialize at random activation and life
D(i).xc = Int(Rnd * _Width - 1) + 1
D(i).yc = Int(Rnd * _Height - 1) + 1
D(i).c = Int(Rnd * 9) + 7
D(i).life = Int(Rnd * 15)
D(i).active = Int(Rnd * 2)
Next
While _KeyDown(27) = 0
Cls
ExplodeDiamonds
_Limit 10
Wend
Sub NewDiamond (i)
D(i).xc = Int(Rnd * _Width - 1) + 1
D(i).yc = Int(Rnd * _Height - 1) + 1
D(i).c = Int(Rnd * 9) + 7
D(i).life = 0
D(i).active = 1
End Sub
Sub ExplodeDiamonds
For i = 1 To NDiamonds
If D(i).active Then
drawDiamond D(i).xc, D(i).yc, D(i).life, ".", D(i).c
drawDiamond D(i).xc, D(i).yc, D(i).life + 1, ".", D(i).c
drawDiamond D(i).xc, D(i).yc, D(i).life + 2, "+", D(i).c
drawDiamond D(i).xc, D(i).yc, D(i).life + 3, "*", D(i).c
D(i).life = D(i).life + 1
If D(i).life > 15 Then D(i).active = 0: D(i).life = 0
Else
If Rnd > .75 Then NewDiamond i
End If
Next
End Sub
Sub drawDiamond (xc, yc, r, s$, c)
Color c
y1 = yc
y2 = yc
x = xc
i = r
While i >= 0
If y1 > 0 And y1 <= _Height - 1 Then
If x - 2 * i > 0 And x - 2 * i <= _Width - 1 Then Locate y1, x - 2 * i: Print s$;
If x + 2 * i > 0 And x + 2 * i <= _Width - 1 Then Locate y1, x + 2 * i: Print s$;
End If
If y2 > 0 And y2 <= _Height - 1 Then
If x - 2 * i > 0 And x - 2 * i <= _Width - 1 Then Locate y2, x - 2 * i: Print s$;
If x + 2 * i > 0 And x + 2 * i <= _Width - 1 Then Locate y2, x + 2 * i: Print s$;
End If
i = i - 1
y1 = y1 - 1
y2 = y2 + 1
Wend
End SubRE: Exploding Ascii Diamonds - Pete - 11-16-2025
Nice job Mark. I hope that ASCIIhole appreciated it!
+2
Pete
RE: Exploding Ascii Diamonds - Petr - 11-16-2025
That's really nice work, @bplus. Just a few tweaks and you'll have fireworks on Screen 0 for the end of the year.
RE: Exploding Ascii Diamonds - bplus - 11-16-2025
Thankyou Pete and Petr!
Petr "a few tweaks and you'll have fireworks"
That is exactly what started the conversation between AnsciiHole and I
He had a nice diamond thing going from center screen that inspired me to do multiple "layers" anywhere on screen in different phases and color for as long as user wanted to watch. Layers wasn't best choice of word but to start, I was imaginging overlapping diamonds. I do intend to get a version closer to fireworks without _NewImage employment.
RE: Exploding Ascii Circles - bplus - 11-16-2025
Exploding Ascii Circles
Again pure Screen 0
Code: (Select All)
_Title "Exploding Ascii Circles" 'b+ 2025-11-16
' mod Exploding Ascii Diamonds to Circles
' from PM conversations with AsciiHole
Randomize Timer
_FullScreen
Type Circles
As Integer xc, yc, c, life, active
End Type
Const NCircles = 3
Dim Shared C(1 To NCircles) As Circles
For i = 1 To NCircles ' initialize at random activation and life
C(i).xc = Int(Rnd * _Width - 1) + 1
C(i).yc = Int(Rnd * _Height - 1) + 1
C(i).c = Int(Rnd * 9) + 7
C(i).life = Int(Rnd * 15)
C(i).active = Int(Rnd * 2)
Next
While _KeyDown(27) = 0
Cls
ExplodeCircles
_Limit 10
Wend
Sub NewCircles (i)
C(i).xc = Int(Rnd * _Width - 1) + 1
C(i).yc = Int(Rnd * _Height - 1) + 1
C(i).c = Int(Rnd * 9) + 7
C(i).life = 0
C(i).active = 1
End Sub
Sub ExplodeCircles
For i = 1 To NCircles
If C(i).active Then
For dot = 0 To 3
drawCircles C(i).xc, C(i).yc, C(i).life + dot, ".", C(i).c
Next
drawCircles C(i).xc, C(i).yc, C(i).life + 4, "+", C(i).c
drawCircles C(i).xc, C(i).yc, C(i).life + 5, "*", C(i).c
C(i).life = C(i).life + 1
If C(i).life > 15 Then C(i).active = 0: C(i).life = 0
Else
If Rnd > .75 Then NewCircles i
End If
Next
End Sub
Sub drawCircles (xc, yc, r, s$, c)
Color c
For a = 0 To _Pi(2) - .001 Step _Pi(1 / 12)
x = Int(xc + 2 * r * Cos(a))
If x > 0 And x <= _Width - 1 Then
y = Int(yc + r * Sin(a))
If y > 0 And y <= _Height - 1 Then
Locate y, x: Print s$;
End If
End If
Next
End SubThanks Pete, Petr for encouragement and AsciiHole for the challenge.
RE: Exploding Ascii Diamonds - Dav - 11-16-2025
Awesome, bplus!
- Dav