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?  ;-))

Code: (Select All)

'Rain Drain.bas started 2017-09-13
'translated from
'Rain Drain.bas  SmallBASIC 0.12.9 [B+=MGA] 2017-04-26

' 2020-08-29 Rain Drain 2: What if we move one side of every line up and down?

_Define A-Z As SINGLE
Randomize Timer
Const xmax = 1100
Const ymax = 700

Screen _NewImage(xmax, ymax, 32)
_FullScreen
_Title "Rain Drain 2:   spacebar for new arrangement,    esc to quit"

Type ball
    x As Single
    y As Single
    speed As Single
    r As Single
    c As Long
End Type

Type bLine
    x1 As Single
    y1 As Single
    x2 As Single
    y2 As Single
    a As Double
End Type

While _KeyDown(27) = 0
    balls = 1500
    ReDim b(balls) As ball
    For i = 1 To balls
        b(i).x = Rnd * xmax
        b(i).y = Rnd * ymax
        b(i).speed = 9.85
        b(i).r = 6
        b(i).c = _RGB(0, rand%(200, 255), rand%(200, 255))
    Next

    m = 10
    nbl = 12
    ReDim bl(nbl) As bLine
    For i = 1 To nbl
        d = rand%(50, 200)
        bl(i).x1 = rand%(m, xmax - d - m)
        bl(i).y1 = i * ymax / nbl - 10
        bl(i).a = Rnd * _Pi(1 / 4) - _Pi(1 / 8)
        bl(i).x2 = bl(i).x1 + d * Cos(bl(i).a)
        bl(i).y2 = bl(i).y1 + d * Sin(bl(i).a)
    Next
    dir = .5: lp = 0
    While 1
        Cls
        If 32 = _KeyHit Then
            Exit While
        ElseIf 27 = _KeyHit Then
            End
        End If
        lp = lp + dir
        If lp > 50 Then dir = -dir
        If lp < -50 Then dir = -dir

        For j = 1 To balls
            If b(j).y - b(j).r > ymax Or b(j).x + b(j).r < 0 Or b(j).x - b(j).r > xmax Then
                b(j).x = rand%(0, xmax): b(j).y = 0
            End If
            fcirc b(j).x, b(j).y, b(j).r, b(j).c
            testx = b(j).x + b(j).speed * Cos(_Pi(.5))
            testy = b(j).y + b(j).speed * Sin(_Pi(.5))
            cFlag = 0
            For i = 1 To nbl
                Color _RGB(255, 0, 0)
                If j = 1 Then bl(i).y1 = bl(i).y1 + dir
                Line (bl(i).x1, bl(i).y1)-(bl(i).x2, bl(i).y2)
                If cFlag = 0 Then
                    If hitLine(testx, testy, b(j).r, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) Then
                        bx1 = b(j).x + b(j).speed * Cos(bl(i).a)
                        bx2 = b(j).x + b(j).speed * Cos(_Pi(1) - bl(i).a)
                        by1 = yy(bx1, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
                        by2 = yy(bx2, bl(i).x1, bl(i).y1, bl(i).x2, bl(i).y2) - b(j).r - 1
                        If by1 = (-9999 - b(j).r - 1) Or by2 = (-9999 - b(j).r - 1) Then
                            cFlag = 0: Exit For
                        End If
                        If by1 >= by2 Then b(j).y = by1: b(j).x = bx1 Else b(j).y = by2: b(j).x = bx2
                        cFlag = 1
                    End If
                End If
            Next
            If cFlag = 0 Then b(j).x = testx: b(j).y = testy
        Next
        _Limit 20
        _Display
    Wend
Wend

Function hitLine (x, y, r, xx1, yy1, xx2, yy2)
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
    If x1 > x2 Then Swap x1, x2: Swap y1, y2
    If x < x1 Or x > x2 Then hitLine = 0: Exit Function
    If ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 - r < y And y < ((y2 - y1) / (x2 - x1)) * (x - x1) + y1 + r Then
        hitLine = 1
    Else
        hitLine = 0
    End If
End Function

Function yy (x, xx1, yy1, xx2, yy2) 'this puts drop on line
    'copy parameters that are changed
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2
    If x1 > x2 Then Swap x1, x2: Swap y1, y2
    If x1 <= x And x <= x2 Then
        yy = ((y2 - y1) / (x2 - x1)) * (x - x1) + y1
    Else
        yy = -9999
    End If
End Function

Function rand% (lo%, hi%)
    rand% = (Rnd * (hi% - lo% + 1)) \ 1 + lo%
End Function

Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, 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), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub