Code: (Select All)

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
' 2022-07-04 mods for The Forth
Const nR = 9, t = "     Celebrating July 4th, 2022 at QB64 PE 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, Let Freedom Ring!....."
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)
_ScreenMove 0, 0
Dim tmp&(0 To 10)
lastt = 20
sc& = _NewImage(640, 350, 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 And .56 * scroll < _DesktopHeight Then
        tp = (tp + 1) Mod 10
        tmp&(tp) = _NewImage(640 + scroll, 358 + .56 * 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

   

(07-04-2022, 09:54 PM)bplus Wrote: Yeah, they swing a mean sword or 2 that's for sure but can they code in QB64?  ;-))