OK the leaves are more satisfactory in my eyes and experience.
Fall banner bplus 2023-09-05A
Less leaves and way less falling leaves so a set will run much longer, 2500 loops instead of 1500, to get barer trees before switch.
Fall banner bplus 2023-09-05A
Code: (Select All)
'Option _Explicit
'_Title "Fall Foliage Banner Move Leaves" 2023-09-03 bak copy
' 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.
' 2023-09-03 try to fix font print to print while leaves are falling
' tweak numbers for falling leaves for more and not too leaden.
' 2023-09-03 FontFlag to signal FPrint is done
' 2023-09-04 do not stop leaves falling when on a tree trunk
' Ran into problems with QBJS handling Point see commented code in MoveLeaf
' So this keeps moving leaves without Point
' Clean up code a bit fix letters shadows, toss junk subs
' Aha! found a way to get leaves off tree trunks = redraw trunks!
' New Type Tree
' 2023-09-05 fix wind so it is continuous between 0 and .5?
' less leaves too
Type treeType
x As Single
y As Single
r As Single
h As Single
End Type
Type new_Leaf
x As Single
y As Single
w As Single
h As Single
c As _Unsigned Long
isFree As Integer
rx As Integer
ry As Integer
yvel As Single
yacc As Single
End Type
Const gravity = .0010
Dim Shared totalLeaves As Long
Dim Shared horizon
Dim Shared wind
Dim Shared stopFrame As Long
Dim Shared FontFlag As Long ' to signal Font has been finished
'Dim Shared TreeTrunkClr As _Unsigned Long
' TreeTrunkClr = _RGB32(60, 30, 15) ' lev 0 color QBJS Point not working
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 = 1200 ' for banner 1400 doesn't fit my screen so using 1200 for broader expanse look
ymx = 256
Screen _NewImage(xmx, ymx, 32) ' grymmjack set on making this 1400 it appears OK
Dim spattern$(0 To 255) ' for 9x9 fonts from string patterns some reworked or added for banner
LoadPatterns9x9 spattern$()
Dim As Long i, scene, trees, windChange
Dim gust
While 1
'Draw scene:
ReDim Shared leaf(30000) As new_Leaf
totalLeaves = 0
stopFrame = 0
FontFlag = 0
windChange = 1
gust = .01
Cls
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)
Line (0, i)-(xmx, i)
Next
'fallen leaves:
For i = 1 To 300 'less of these at start, as they'll grow in number anyway
createLeaf rand&(0, xmx), rand&(horizon + 5, ymx)
Next
' trees
trees = rand&(5, 12)
ReDim tree(1 To trees) As treeType
For i = 1 To trees
tree(i).x = rand&(50, xmx - 50)
tree(i).y = horizon + .04 * ymx + i / trees * (ymx - horizon - .1 * ymx)
tree(i).r = .01 * tree(i).y
tree(i).h = rand&(tree(i).y * .15, tree(i).y * .18)
branch tree(i).x, tree(i).y, tree(i).r, 90, tree(i).h, 0, 7
Next
If scene < -1 Then _FreeImage scene
scene = _CopyImage(0) ' take a picture of bare trees before they are clothed with leaves
'Animate scene:
While FontFlag < 2500 ' keep going more loops to drop allot of leaves allow trees to become bare
If wind + windChange * gust < 0 Then windChange = -windChange
If wind + windChange * gust > 5 Then windChange = -windChange
wind = wind + windChange * gust
_PutImage , scene
letLeafGo
For i = 1 To totalLeaves
moveLeaf leaf(i)
Line (leaf(i).x, leaf(i).y)-Step(leaf(i).w, leaf(i).h), leaf(i).c, BF
Next
_PutImage (20, 80)-(150, 210), Logo, 0
_PutImage (xmx - 150, 80)-(xmx - 20, 210), Logo, 0
' this draws one letter squares at a time until title is complete
' the FontFlag is increased by 1 for 1500 loops after letters are complete
FPrint "QB64PE FALL EDITION", spattern$(), 12, 20, 5, 1, &HFFAAFF00
' draw tree trunks again
For i = 1 To trees
branch tree(i).x, tree(i).y, tree(i).r, 90, tree(i).h, 0, -1
Next
' debugging wind and changes
'_Title "Wind:" + Str$(wind) + " WindChange:" + Str$(windChange)
_Display
_Limit 30
Wend
Wend
Sub branch (xx, yy, startrr, angDD, lengthh, levv, stopLev)
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 > stopLev 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, stopLev
branch x2, y2, .8 * startr, angD - 22 - rand&(-10, 19), rand&(.75 * length, .9 * length), lev, stopLev
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 createLeaf (x, y)
Dim sp, xoff, yoff, woff, hoff
If Rnd < .6 Then
sp = 15
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&(100, 250), rand&(50, 255), rand&(0, 40))
If Rnd < .5 Then leaf(totalLeaves).rx = -2 Else leaf(totalLeaves).rx = 2
If Rnd < .5 Then leaf(totalLeaves).ry = -1 Else leaf(totalLeaves).ry = 1
End If
End Sub
Sub moveLeaf (idx As new_Leaf)
If idx.isFree Then 'leaves falling
If idx.y < horizon Then ' above ground
idx.yacc = idx.yacc + 3 * gravity
idx.yvel = idx.yvel + idx.yacc
idx.y = idx.y + idx.yvel
Else ' below horizon and falling time to stop
idx.yacc = idx.yacc + 3 * gravity
idx.yvel = idx.yvel + idx.yacc
idx.y = idx.y + idx.yvel
If idx.y > horizon Then ' stop leaves from going to bottom of screen
idx.isFree = 0
End If
End If
idx.x = idx.x + wind
Else
If idx.y < horizon Then 'leaves waving in their branch
If Rnd <= wind / 500 Then idx.x = idx.x + idx.rx: idx.rx = -idx.rx
If Rnd <= wind / 500 Then idx.y = idx.y + idx.ry: idx.ry = -idx.ry
Else 'leaves are on ground but can move too down and to right only
If Rnd <= wind / 500 Then ' move down wind
idx.x = idx.x + 2
Else
If Rnd < wind / 500 Then idx.x = idx.x + idx.rx: idx.rx = -idx.rx
End If
If Rnd <= wind / 500 Then ' move down wind
idx.y = idx.y + 1
Else
If Rnd < wind / 500 Then idx.y = idx.y + idx.ry: idx.ry = -idx.ry
End If
End If
End If
End Sub
Sub letLeafGo
Dim which&, i&
For i& = 1 To 5
If Rnd <= wind / 30 Then
which& = rand&(1, totalLeaves)
'If which& < 1 Then which& = 1
'If which& > totalLeaves Then which& = totalLeaves
leaf(which&).isFree = -1
End If
Next
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~&)
' 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 As Long frame
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
frame = frame + 1
If frame >= stopFrame Then
stopFrame = stopFrame + 1
Exit Sub
End If
End If
Next
Next
Next
End If
Next
FontFlag = FontFlag + 1
' _Title Str$(FontFlag) ' checking how long it needs to cycle after letters are complete
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) + "...133..."
SPattern(a) = SPattern(a) + "..1...3.."
SPattern(a) = SPattern(a) + "..1...3.."
SPattern(a) = SPattern(a) + ".1.....3."
SPattern(a) = SPattern(a) + ".1222223."
SPattern(a) = SPattern(a) + ".1.....3."
SPattern(a) = SPattern(a) + "1.......3"
SPattern(a) = SPattern(a) + "1.......3"
SPattern(a) = SPattern(a) + "1.......3"
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) + "..11111.."
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) + "..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....3"
SPattern(a) = SPattern(a) + "..1.....3"
SPattern(a) = SPattern(a) + ".1......3"
SPattern(a) = SPattern(a) + "1.......3"
SPattern(a) = SPattern(a) + "122222223"
SPattern(a) = SPattern(a) + "........3"
SPattern(a) = SPattern(a) + "........3"
SPattern(a) = SPattern(a) + "........3"
SPattern(a) = SPattern(a) + "........3"
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 SubLess leaves and way less falling leaves so a set will run much longer, 2500 loops instead of 1500, to get barer trees before switch.
724 855 599 923 575 468 400 206 147 564 878 823 652 556 bxor cross forever