Exploding Ascii Diamonds

[bplus]

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 Sub

[Pete]

Nice job Mark. I hope that ASCIIhole appreciated it!  

+2

Pete

[Petr]

That's really nice work, @bplus. Just a few tweaks and you'll have fireworks on Screen 0 for the end of the year. 

[bplus]

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.

[bplus]

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 Sub

   

Thanks Pete, Petr for encouragement and AsciiHole for the challenge.

[Dav]

Awesome, bplus!

- Dav