+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Works in Progress (https://qb64phoenix.com/forum/forumdisplay.php?fid=9)
+---- Thread: Fall Banner bplus WIP (/showthread.php?tid=1967)
Fall Banner bplus WIP - bplus - 09-03-2023
OK much better! I got the leaves falling while the Title is printing out plus it looks like strong wind is blowing them off.
Fall Banner 2023 bplus WIP
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.
' 2023-09-03 try to fix font print to print while leaves are falling
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 = .0005
Dim Shared totalLeaves As Long
Dim Shared horizon
Dim Shared wind
Dim Shared lastLeaf As Long
Dim Shared stopFrame As Long
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)
FontImage = _NewImage(_Width, 100, 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
stopFrame = 0
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)
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 + 30) Or (tim > Timer(.01)) ' + 20 leaves off the N
If Rnd < .5 Then wind = Rnd / 150 - Rnd / 800 Else wind = 0
_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
_Display
_Limit 30
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.randomMove = 1 Then
idx.randomMove = -1
Else
idx.randomMove = 1
End If
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
If Rnd <= .02 And wind Then idx.x = idx.x + idx.randomMove
If Rnd <= .02 And wind Then idx.y = idx.y + idx.randomMove
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
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&, i&
If Timer(.01) - lastLeaf > .002 Then
For i& = 1 To 10
which& = rand&(1, totalLeaves)
If which& < 1 Then which& = 1
If which& > totalLeaves Then which& = totalLeaves
leaf(which&).isFree = -1
lastLeaf = Timer
Next
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~&)
' 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
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 SubRE: Fall Banner bplus WIP - grymmjack - 09-04-2023
Looks great @bplus! Well done.
https://staging.qb64phoenix.com/
I put it online so you could see. I also modified it to use 1400 to show you what it will look like live.
LMK if it's ok.
RE: Fall Banner bplus WIP - bplus - 09-04-2023
(09-04-2023, 12:01 AM)grymmjack Wrote: Looks great @bplus! Well done.
https://staging.qb64phoenix.com/
I put it online so you could see. I also modified it to use 1400 to show you what it will look like live.
LMK if it's ok.
Yeah see I'd rather not have scroll bars, wow even a vertical one!
Imagine what Leonardo would say if they put the Mona Lisa in scroll bars.
Here is my view of it:
It's not terrible because the Font Title fits and you can see at least one Logo. Wow a vertical scroll bar too, rats!
Gotta say it is really cool to see the animation in a banner! Thanks @grymmjack for the test.
RE: Fall Banner bplus WIP - mnrvovrfc - 09-04-2023
I'm using Firefox v117 AppImage on Debian v12 "Bookworm", MATE desktop (old GNOME).
Maybe it's just me, but the animation interrupts before it finishes drawing all the letters on the top. It goes drawing each block of the letters slowly because it also has to drop some leaves from the trees. It looks great, only it doesn't finish drawing the message. I don't mind the scrollbars but the right-hand-side QB64PE logo, which is hidden at first is becoming lonely. I hope this description is helpful.
RE: Fall Banner bplus WIP - bplus - 09-04-2023
(09-04-2023, 01:57 AM)mnrvovrfc Wrote: I'm using Firefox v117 AppImage on Debian v12 "Bookworm", MATE desktop (old GNOME).
Maybe it's just me, but the animation interrupts before it finishes drawing all the letters on the top. It goes drawing each block of the letters slowly because it also has to drop some leaves from the trees. It looks great, only it doesn't finish drawing the message. I don't mind the scrollbars but the right-hand-side QB64PE logo, which is hidden at first is becoming lonely. I hope this description is helpful.
Ah the timer is different in Linux. The drawing of letters was timed in Windows to complete the drawing of letters in Title AND allow allot more leaves to fall before switching to the next scene. I could set a flag in the FPrint sub letting the main code know when the letters are done instead of using a timer.
Or maybe it is allot of processing for CPU and it is needing more than 1/30 of a second to complete a loop. That's more likely what is off. The flag should help that too.
RE: Fall Banner bplus WIP - bplus - 09-04-2023
FontFlag is working great! I can get most of leaves fallen before cycling around to main loop for another set.
Fall Banner with moving leaves and FontFlag
Code: (Select All)
'Option _Explicit
'_Title "Fall Foliage Banner Move Leaves bak 2023-09-03"
' 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
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 = .0010
Dim Shared totalLeaves As Long
Dim Shared horizon
Dim Shared wind
Dim Shared lastLeaf As Long
Dim Shared stopFrame As Long
Dim Shared FontFlag As Long ' to signal Font has been finished
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
stopFrame = 0
FontFlag = 0
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)
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 FontFlag < 1500 ' keep going 1500 more loops to drop allot of leaves
If Rnd < .4 Then wind = Rnd / 50 - Rnd / 800 Else wind = 0
_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
_Display
_Limit 30
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.randomMove = 1 Then
idx.randomMove = -1
Else
idx.randomMove = 1
End If
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
If Rnd <= .02 And wind Then idx.x = idx.x + idx.randomMove
If Rnd <= .02 And wind Then idx.y = idx.y + idx.randomMove
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
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&, i&
If Timer(.01) - lastLeaf > .002 Then
For i& = 1 To 10
which& = rand&(1, totalLeaves)
If which& < 1 Then which& = 1
If which& > totalLeaves Then which& = totalLeaves
leaf(which&).isFree = -1
lastLeaf = Timer
Next
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~&)
' 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) + "...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
RE: Fall Banner bplus WIP - grymmjack - 09-04-2023
(09-04-2023, 01:31 AM)bplus Wrote: Yeah see I'd rather not have scroll bars, wow even a vertical one!
Imagine what Leonardo would say if they put the Mona Lisa in scroll bars.
Here is my view of it:
It's not terrible because the Font Title fits and you can see at least one Logo. Wow a vertical scroll bar too, rats!
Gotta say it is really cool to see the animation in a banner! Thanks @grymmjack for the test.
I can try to get rid of the scrollbars.
RE: Fall Banner bplus WIP - grymmjack - 09-04-2023
(09-04-2023, 01:31 AM)bplus Wrote: Yeah see I'd rather not have scroll bars, wow even a vertical one!
I have updated staging with your banner FontFlag and added the following for your code to remove the scrollbars in qbjs:
Code: (Select All)
Import Dom From "lib/web/dom.bas"
Dom.Container().style.overflow = "hidden"Put this right at the top.
RE: Fall Banner bplus WIP - bplus - 09-04-2023
OK thanks @grymmjack
I am getting use to seeing this with only the left Logo only. Not bad.
I hope this version works in Linux as it does in Windows. Might take a really long time to print all Letters and do another 1500 loops of falling leaves on slower machines. So basically one banner set per visit?
Next fix, don't allow leaves to land on tree trunks a foot or 2 up from the ground. Doesn't look right.
RE: Fall Banner bplus WIP - bplus - 09-04-2023
OK lot's of little things including fixing font prints, adding treeType to fix leaves sticking to trees 2 feet up the trunk. I tried Point first to detect tree trunk color. It did not work all that great in QB64 and QBJS did not like at all. So I found another way around by redrawing the tree trunks.
So here is latest:
[Broken link error #413]
Hey is the QBJS Server is giving me an error when I try to test the Shared Code link from this forum. I retried 3 times. The code works fine in QBJS but the shared code link 413's an Error???
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
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
xvel As Single
yacc As Single
xacc 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
While 1
'Draw scene:
ReDim Shared leaf(30000) As new_Leaf
totalLeaves = 0
stopFrame = 0
FontFlag = 0
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 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)
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 < 1500 ' keep going 1500 more loops to drop allot of leaves
If Rnd < .4 Then wind = Rnd / 50 - Rnd / 800 Else wind = 0
_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
_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
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 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 hor and falling
idx.yacc = idx.yacc + 3 * gravity
idx.yvel = idx.yvel + idx.yacc
idx.y = idx.y + idx.yvel
If idx.y >= horizon Then ' dont stop on tree trunk
' QBJS doesn't like point it's OK it wasn't working very well anyway
'If Point(idx.x, idx.y) <> TreeTrunkClr Then
' If Point(idx.x + idx.w, idx.y + idx.h) <> TreeTrunkClr Then
' If Point(idx.x + .5 * idx.w, idx.y + .5 * idx.h) <> TreeTrunkClr Then
idx.isFree = 0
' End If
' End If
'End If
End If
End If
idx.xacc = idx.xacc + wind
idx.xvel = idx.xvel + idx.xacc
idx.x = idx.x + idx.xvel
If Rnd <= .1 Then idx.x = idx.x + idx.ry: idx.rx = -idx.rx
If Rnd <= .1 Then idx.y = idx.y + idx.ry: idx.ry = -idx.ry
Else
'leaves waving in their branch
If idx.y < horizon Then
If Rnd <= .02 Then idx.x = idx.x + idx.rx: idx.rx = -idx.rx
If Rnd <= .02 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 <= .025 Then idx.x = idx.x + 1
If Rnd <= .0025 Then idx.y = idx.y + 1
' QBJS doesn't like Point it wasn't working very well anyway
'If Point(idx.x + 1, idx.y) <> TreeTrunkClr Then
' If Point(idx.x + 1 + idx.w, idx.y + idx.h) <> TreeTrunkClr Then
' If Point(idx.x + 1 + .5 * idx.w, idx.y + .5 * idx.h) <> TreeTrunkClr Then
' idx.isFree = 0
' End If
' End If
'End If
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&, i&
For i& = 1 To 5
which& = rand&(1, totalLeaves)
If which& < 1 Then which& = 1
If which& > totalLeaves Then which& = totalLeaves
leaf(which&).isFree = -1
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 Sub