Fall Banner Contest?

[bplus]

@grymmjack could you please run a Forum Banner test on the following code. It is likely my final submission if the width works out at 970 pixels wide.

Fall Banner bplus test at 970 wide

Here is code that works both QB64 and QBJS:

Code: (Select All)

'Option _Explicit
'_Title "Fall Foliage Banner"
' started 2017-10-21 by bplus as: fall foliage.bas SmallBASIC 0.12.9 (B+=MGA) 2017-10-21

' 2023-08-30 start of QBJS Banner
' 2023-08-31 Logo and Hills added

' 2023-09-01 Fellippe I see contributed allot to orig code with moving leaves
' Also thanks to grymmjack for getting me starting of PFont and font patterns.
' Also thanks to dbox for catching all my errors with QBJS.

Type new_Leaf
    x As Single
    y As Single
    w As Single
    h As Single
    c As _Unsigned Long
    isFree As Integer
    randomMove As Integer
    yvel As Single
    xvel As Single
    yacc As Single
    xacc As Single
End Type

Const gravity = .003
Dim Shared totalLeaves As Long
Dim Shared horizon
Dim Shared wind
Dim Shared lastLeaf

Dim As Long Logo
$If WEB Then
        Logo = _LoadImage("https://qb64phoenix.com/forum/attachment.php?aid=2206", 32)
$Else
    Logo = _LoadImage("peLogo.png", 32)
$End If

'now for full viewing enjoyment xmx = screen width, ymx = screen height
Dim Shared xmx, ymx
xmx = 970 ' for banner
ymx = 256
Screen _NewImage(xmx, ymx, 32)

Dim spattern$(0 To 255) ' for 9x9 fonts from string patterns some reworked or added for banner
LoadPatterns9x9 spattern$()
Dim As Long i, scene
Dim trees, y, r, h, tim

While 1
    'Draw scene:
    ReDim Shared leaf(30000) As new_Leaf
    totalLeaves = 0
    Cls

    wind = Rnd / 300

    horizon = rand&(.8 * ymx, .9 * ymx)

    'sky and hill background
    drawLandscape
    For i = horizon To ymx
        midInk 160, 188, 50, 100, 60, 25, (i - horizon) / (ymx - horizon)
        lien 0, i, xmx, i
    Next

    'fallen leaves:
    For i = 1 To 50 'less of these at start, as they'll grow in number anyway
        createLeaf rand&(0, xmx), rand&(horizon * 1.002, ymx)
    Next

    ' trees
    trees = rand&(5, 12)
    For i = 1 To trees
        y = horizon + .04 * ymx + i / trees * (ymx - horizon - .1 * ymx)
        r = .01 * y: h = rand&(y * .15, y * .18)
        branch rand&(50, xmx - 50), y, r, 90, h, 0
    Next
    _PutImage (20, 80)-(150, 210), Logo, 0
    _PutImage (xmx - 150, 80)-(xmx - 20, 210), Logo, 0
    FPrint "QB64PE FALL EDITION", spattern$(), 12, 20, 5, 1, &HFFAAFF00, 1
    _Display
    If scene < -1 Then _FreeImage scene
    scene = _CopyImage(0)
    tim = Timer(.01)
    'Animate scene:
    While (Timer(.01) < tim + 45) Or (tim > Timer(.01))
        _PutImage , scene
        letLeafGo
        For i = 1 To totalLeaves
            moveLeaf leaf(i)
            drawLeaf leaf(i)
        Next
        _PutImage (20, 80)-(150, 210), Logo, 0
        _PutImage (xmx - 150, 80)-(xmx - 20, 210), Logo, 0
        FPrint "QB64PE FALL EDITION", spattern$(), 12, 20, 5, 1, &HFFAAFF00, 0
        _Display
        _Limit 60
    Wend
Wend

Sub branch (xx, yy, startrr, angDD, lengthh, levv)
    Dim x, y, lev, length, angD, startr, x2, y2, dx, dy, i
    Dim bc~&
    x = xx: y = yy
    lev = levv
    length = lengthh
    angD = angDD
    startr = startrr
    x2 = x + Cos(_D2R(angD)) * length
    y2 = y - Sin(_D2R(angD)) * length
    dx = (x2 - x) / length
    dy = (y2 - y) / length
    bc~& = _RGB32(60 + 12 * lev, 30 + 7 * lev, 15 + 5 * lev)
    If 2 * startr <= 1 Then
        Line (x, y)-(x2, y2), bc~&
    Else
        For i = 0 To length
            fCirc x + dx * i, y + dy * i, startr, bc~&
        Next
    End If
    If lev > 1 Then createLeaf x2, y2
    If .8 * startr < .1 Or lev > 7 Or length < 3 Then Exit Sub
    lev = lev + 1
    branch x2, y2, .8 * startr, angD + 22 + rand&(-10, 19), rand&(.75 * length, .9 * length), lev
    branch x2, y2, .8 * startr, angD - 22 - rand&(-10, 19), rand&(.75 * length, .9 * length), lev
End Sub

Sub fCirc (CX As Long, CY As Long, R As Long, c As _Unsigned 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), 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

Sub fRect (x1, y1, x2, y2, c&)
    Line (x1, y1)-(x2, y2), c&, BF
End Sub

Sub fRectStep (x1, y1, x2, y2)
    Line (x1, y1)-Step(x2, y2), , BF
End Sub

Sub lien (x1, y1, x2, y2)
    Line (x1, y1)-(x2, y2)
End Sub

Sub createLeaf (x, y)
    Dim sp, leafs, n, xoff, yoff, woff, hoff
    sp = 15: leafs = rand&(0, 2)
    For n = 1 To leafs
        xoff = x + Rnd * sp - Rnd * sp
        yoff = y + Rnd * sp - Rnd * sp
        woff = 3 + Rnd * 3
        hoff = 3 + Rnd * 3
        totalLeaves = totalLeaves + 1
        If totalLeaves > UBound(leaf) Then ReDim _Preserve leaf(1 To UBound(leaf) + 5000) As new_Leaf
        leaf(totalLeaves).x = xoff
        leaf(totalLeaves).y = yoff
        leaf(totalLeaves).w = woff
        leaf(totalLeaves).h = hoff
        leaf(totalLeaves).c = _RGB32(rand&(50, 250), rand&(25, 255), rand&(0, 40))
    Next
End Sub

Sub moveLeaf (idx As new_Leaf)
    If idx.isFree Then
        'leaves falling
        If idx.y < horizon Then
            idx.yacc = idx.yacc + 3 * gravity
            idx.yvel = idx.yvel + idx.yacc
            idx.y = idx.y + idx.yvel
        Else
            idx.yacc = idx.yacc + 3 * gravity
            idx.yvel = idx.yvel + idx.yacc
            idx.y = idx.y + idx.yvel
            If idx.y >= horizon Then idx.isFree = 0
        End If

        idx.xacc = idx.xacc + wind
        idx.xvel = idx.xvel + idx.xacc
        idx.x = idx.x + idx.xvel
    Else
        'leaves waving in their branch
        If idx.y < horizon Then
            If idx.randomMove = 1 Then
                idx.randomMove = -1
            Else
                idx.randomMove = 1
            End If
            If Rnd <= .01 Then idx.x = idx.x + idx.randomMove
            If Rnd <= .01 Then idx.y = idx.y + idx.randomMove
        End If
    End If
End Sub

Sub allFree
    Dim i&
    For i& = 1 To totalLeaves
        leaf(i&).isFree = -1
    Next
End Sub

Sub letLeafGo
    Dim which&
    If Timer - lastLeaf > .22 Then
        which& = rand&(1, totalLeaves)
        If which& < 1 Then which& = 1
        If which& > totalLeaves Then which& = totalLeaves
        leaf(which&).isFree = -1
        lastLeaf = Timer
    End If
End Sub

Sub drawLeaf (idx As new_Leaf)
    Color idx.c
    fRectStep idx.x, idx.y, idx.w, idx.h
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 drawLandscape
    'needs midInk, rand&

    Dim i As Long, startH As Single, rr As Long, gg As Long, bb As Long
    Dim mountain As Long, Xright As Single, y As Single, upDown As Single, range As Single
    Dim lastx As Single, X As Long
    'the sky
    For i = 0 To ymx
        midInk 150, 150, 220, 255, 255, 255, i / ymx
        Line (0, i)-(xmx, i)
    Next
    'the land
    startH = ymx - 200
    rr = 125: gg = 140: bb = 120
    For mountain = 1 To 4
        Xright = 0
        y = startH
        While Xright < xmx
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (Rnd * .8 - .35) * (mountain * .5)
            range = Xright + rand(15, 25) * 2.5 / mountain
            lastx = Xright - 1
            For X = Xright To range
                y = y + upDown
                Color _RGB(rr, gg, bb)
                Line (lastx, y)-(X, ymx), , BF 'just lines weren't filling right
                lastx = X
            Next
            Xright = range
        Wend
        rr = rand&(rr + 65, rr): gg = rand&(gg + 45, gg): bb = rand&(bb - 25, bb)
        If rr < 0 Then rr = 0
        If gg < 0 Then gg = 0
        If bb < 0 Then bb = 0
        startH = startH + rand&(5, 20)
    Next
End Sub

Sub FPrint (s$, PA$(), x%, y%, scale%, spacing%, colr~&, pause)
    ' s$ is string to "print" out
    ' PA$() is the array of string holding the font THE SQUARE pattern (must be NxN pattern)
    ' x, y top, left corner of print just like _PrintString
    ' scale is multiplier of pixeled font at NxN so now is Scale * N x Scale * N
    ' spacing is amount of pixels * scale between letters
    ' color~& type allows up to _RGB32() colors
    Dim As Integer ls, l, a, sq, r, c, i, digi
    Dim d$
    ls = Len(s$)
    For l = 1 To ls
        a = Asc(s$, l)
        If Len(PA$(a)) Then ' do we have a pattern
            sq = Sqr(Len(PA$(a)))
            'Print Chr$(a), sq  'debug
            For digi = 1 To 9
                d$ = _Trim$(Str$(digi))
                For r = 0 To sq - 1 ' row and col of letter block
                    For c = 0 To sq - 1
                        i = (r * sq) + c + 1
                        $If WEB Then
                                i = i + 1
                        $End If
                        If Mid$(PA$(a), i, 1) = d$ Then
                            Line (x% + ((l - 1) * (sq + spacing%) + c) * scale% + 4, y% + r * scale% + 4)-Step(scale% - 1, scale% - 1), &HFF000000, BF
                            Line (x% + ((l - 1) * (sq + spacing%) + c) * scale% - 1, y% + r * scale% - 1)-Step(scale% - 1, scale% - 1), &HFFFFFFFF, BF
                            Line (x% + ((l - 1) * (sq + spacing%) + c) * scale%, y% + r * scale%)-Step(scale% - 1, scale% - 1), colr~&, BF
                            If pause Then _Delay .04: _Display
                        End If
                    Next
                Next
            Next
        End If
    Next
End Sub

Sub LoadPatterns9x9 (SPattern() As String)
    Dim As Integer a
    a = Asc("S")
    SPattern(a) = SPattern(a) + "..111111."
    SPattern(a) = SPattern(a) + ".2......."
    SPattern(a) = SPattern(a) + ".2......."
    SPattern(a) = SPattern(a) + "..3......"
    SPattern(a) = SPattern(a) + "...333..."
    SPattern(a) = SPattern(a) + "......4.."
    SPattern(a) = SPattern(a) + ".......4."
    SPattern(a) = SPattern(a) + ".......4."
    SPattern(a) = SPattern(a) + "5555555.."
    a = Asc("T")
    SPattern(a) = SPattern(a) + "111111111"
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    SPattern(a) = SPattern(a) + "....2...."
    a = Asc("A")
    SPattern(a) = SPattern(a) + "...122..."
    SPattern(a) = SPattern(a) + "..1...2.."
    SPattern(a) = SPattern(a) + "..1...2.."
    SPattern(a) = SPattern(a) + ".1.....2."
    SPattern(a) = SPattern(a) + ".1333332."
    SPattern(a) = SPattern(a) + ".1.....2."
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    a = Asc("F")
    SPattern(a) = SPattern(a) + "122222222"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1333333.."
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    a = Asc("I")
    SPattern(a) = SPattern(a) + "..22222.."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "....1...."
    SPattern(a) = SPattern(a) + "..33333.."
    a = Asc("G")
    SPattern(a) = SPattern(a) + ".1111111."
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2....4444"
    SPattern(a) = SPattern(a) + "2.......5"
    SPattern(a) = SPattern(a) + "2......35"
    SPattern(a) = SPattern(a) + "2.....3.5"
    SPattern(a) = SPattern(a) + ".33333..5"
    a = Asc("Q")
    SPattern(a) = SPattern(a) + "..11111.."
    SPattern(a) = SPattern(a) + ".2.....4."
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2....5..4"
    SPattern(a) = SPattern(a) + "2.....5.4"
    SPattern(a) = SPattern(a) + ".2....55."
    SPattern(a) = SPattern(a) + "..33333.5"
    a = Asc("O")
    SPattern(a) = SPattern(a) + "..11111.."
    SPattern(a) = SPattern(a) + ".2.....4."
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + ".2.....4."
    SPattern(a) = SPattern(a) + "..33333.."
    a = Asc("D")
    SPattern(a) = SPattern(a) + "1222222.."
    SPattern(a) = SPattern(a) + "1......3."
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1......3."
    SPattern(a) = SPattern(a) + "1444444.."

    a = Asc("6")
    SPattern(a) = SPattern(a) + "..11111.."
    SPattern(a) = SPattern(a) + ".2......."
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2.444444."
    SPattern(a) = SPattern(a) + "24......4"
    SPattern(a) = SPattern(a) + "2.......4"
    SPattern(a) = SPattern(a) + ".2.....4."
    SPattern(a) = SPattern(a) + "..33333.."
    a = Asc("H")
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "133333332"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1.......2"
    a = Asc("4")
    SPattern(a) = SPattern(a) + "...1....2"
    SPattern(a) = SPattern(a) + "..1.....2"
    SPattern(a) = SPattern(a) + ".1......2"
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "133333332"
    SPattern(a) = SPattern(a) + "........2"
    SPattern(a) = SPattern(a) + "........2"
    SPattern(a) = SPattern(a) + "........2"
    SPattern(a) = SPattern(a) + "........2"

    a = Asc("E")
    SPattern(a) = SPattern(a) + "111111111"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2444444.."
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "2........"
    SPattern(a) = SPattern(a) + "233333333"
    a = Asc("N")
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "12......3"
    SPattern(a) = SPattern(a) + "1.2.....3"
    SPattern(a) = SPattern(a) + "1..2....3"
    SPattern(a) = SPattern(a) + "1...2...3"
    SPattern(a) = SPattern(a) + "1....2..3"
    SPattern(a) = SPattern(a) + "1.....2.3"
    SPattern(a) = SPattern(a) + "1......23"
    SPattern(a) = SPattern(a) + "1.......3"
    a = Asc("B")
    SPattern(a) = SPattern(a) + "1222222.."
    SPattern(a) = SPattern(a) + "1......3."
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1......3."
    SPattern(a) = SPattern(a) + "1333333.."
    SPattern(a) = SPattern(a) + "1......4."
    SPattern(a) = SPattern(a) + "1.......4"
    SPattern(a) = SPattern(a) + "1......4."
    SPattern(a) = SPattern(a) + "1444444.."
    a = Asc("L")
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "122222222"
    a = Asc("U")
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + "1.......3"
    SPattern(a) = SPattern(a) + ".2222222."
    a = Asc("P")
    SPattern(a) = SPattern(a) + "1222222.."
    SPattern(a) = SPattern(a) + "1......2."
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1......2."
    SPattern(a) = SPattern(a) + "1333332.."
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    SPattern(a) = SPattern(a) + "1........"
    a = Asc("R")
    SPattern(a) = SPattern(a) + "1222222.."
    SPattern(a) = SPattern(a) + "1......2."
    SPattern(a) = SPattern(a) + "1.......2"
    SPattern(a) = SPattern(a) + "1......2."
    SPattern(a) = SPattern(a) + "1333332.."
    SPattern(a) = SPattern(a) + "1.....4.."
    SPattern(a) = SPattern(a) + "1......4."
    SPattern(a) = SPattern(a) + "1.......4"
    SPattern(a) = SPattern(a) + "1.......4"
End Sub

code ref for bplus: "Fall Banner Move Leaves bak 2023-09-01"