You know what? I am withdrawing from contest for many reasons:
1. I like dbox submission!
2. dbox submission is a real demo of what can be done with QBJS which is really great QB64 option
3. I like the appeal to gamers it would have.
4. Not sure I want that dang pumpkin of mine staring at me for several months
5. Make things easy for @grymmjack
(10-03-2023, 12:07 PM)bplus Wrote: You know what? I am withdrawing from contest for many reasons:
1. I like dbox submission!
2. dbox submission is a real demo of what can be done with QBJS which is really great QB64 option
3. I like the appeal to gamers it would have.
4. Not sure I want that dang pumpkin of mine staring at me for several months
5. Make things easy for @grymmjack
You can always vote for dbox's but I'm sure others were waiting to vote on yours.
New to QB64pe? Visit the QB64 tutorial to get started. QB64 Tutorial
10-03-2023, 02:58 PM (This post was last modified: 10-03-2023, 03:27 PM by bplus.)
OK @TerryRitchie and @dbox who am I to argue with 2 Master Class QB64 coders!?
And just to show the stiff competition dbox has...
@grymmjack you can reset xmx = 1400 but designed and developed xmx = 1200
The line is commented with "!!!!! near top.
OK this code is reset to run just the actual time of day as QBJS gets and translates it, I have removed the random testing of Shared hours variable (also '!!!! commented):
QB64pe:
Code: (Select All)
Option _Explicit
'_Title "Fall Foliage Banner Move Leaves" ' work file for updating
' 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-05A fix wind and make (less) leaves more responsive to wind
' 2023-09-05 1:40P added pumpkin but cheeky in QBJS
' 2023-09-06 add ships
' 2023-09-07 remove ships. G2d.Ellipse draw function in QBJS Fixed!
' fTri function with a Color parameter now.
' 2023-09-08 Coloring by the hours since midnight. Fix day color inside pumpkin, less black.
Randomize Timer
$If WEB Then
Import G2D From "lib/graphics/2d.bas"
$End If
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 sx ' moving pumpkin eyes
Dim Shared hours ' for custom coloring
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
'!!!! [url=https://qb64phoenix.com/forum/member.php?action=profile&uid=259]@grymmjack[/url] either xmx = 1200 or 1400 should work, developed in Windows at 1200 though !!!!!!
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, pumpkinImage, lp, pr, d
Dim gust
pr = 100
While 1
'Draw scene:
ReDim Shared leaf(30000) As new_Leaf
totalLeaves = 0
stopFrame = 0
FontFlag = 0
windChange = 1
gust = .01
' !!!!! see light function for actual hour set for banner afer testing
' !!!!! the following is for random testing of hours
'hours = Rnd * 24 ' testing rnd assignments for hour for color checks, we have sun setting early!
Cls
horizon = rand&(.8 * ymx, .9 * ymx)
'sky and hill background and now ground too
drawLandscape
'pre 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 save placements and radius to redraw trunks
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
lp = (lp + 1) Mod 10
If lp = 1 Then
If pumpkinImage < -1 Then _FreeImage pumpkinImage
pumpkinImage = _NewImage(300, 200, 32)
_Dest pumpkinImage
sx = sx + rand&(-4, 4)
If sx > .7 * pr / 10 Then d = -1 * d: sx = 0 ' spooky pumpkin moves it's eyes
If sx < -.7 * pr / 10 Then d = -1 * d: sx = 0
pumpkin 149, 100, pr, 2
_Dest 0
End If
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 shadows was going to be like hands to 24 hour clock but didn't work out
'For i = 1 To trees
' drawShadow tree(i).x, tree(i).y, tree(i).r
'Next
' 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
Color &HFFFFFFFF, &H01000000 ' announce the hour
_PrintString (20, ymx - 20), "Hours since midnight:" + Str$(Int(hours * 100) / 100)
_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
Function light ' 0 to 100 to add to color for light of day in landscape
' !!!!!!! uncomment the following line for actual banner meanwhile testing rnd hour assignments in main loop
hours = Val(Mid$(Time$, 1, 2)) + Val(Mid$(Time$, 4, 2)) / 60
'hours = 0 ' test total darkness
'hours = 3
'hours = 6
'hours = 9
'hours = 12 ' test total light
'hours = 14
'hours = 16
'hours = 18
'hours = 20
If hours <= 12 Then
light = hours * 180 / 12
Else
light = (24 - hours) * 180 / 12
End If
End Function
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, l
l = light
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, 100 + l), rand&(50, 105 + l), rand&(0, .5 * l))
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)
leaf(which&).isFree = -1
End If
Next
End Sub
Sub midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
Color _RGB32(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& , light
Dim As Long rr, gg, bb, i, X, mountain
Dim As Single startH, Xright, y, upDown, range, lite, hl, lastX
lite = light
hl = .5 * light
'the sky
For i = 0 To ymx
midInk 10 + lite, 10 + lite, 50 + lite, 105 + lite, 105 + lite, 105 + lite, i / ymx
Line (0, i)-(xmx, i)
Next
'stars
For i = 1 To 200
If Rnd < .2 Then
Circle (Rnd * xmx, Rnd * ymx), 1, _RGB32(185, 185, 185)
Else
PSet (Rnd * xmx, Rnd * ymx), _RGB32(185, 185, 185)
End If
Next
'the land
startH = ymx - 200
rr = 35 + hl: gg = 50 + hl: bb = 30 + hl
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
'the level fore ground
For i = horizon To ymx
midInk 105 + hl, 105 + .75 * hl, 10, 25 + hl, 20 + .5 * hl, hl * .5, (i - horizon) / (ymx - horizon)
Line (0, i)-(xmx, i)
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 pumpkin (cx, cy, pr, limit As Integer)
Dim As Long u, i, red
Dim lastr, dx, tx1, tx2, tx3, ty1, ty3, ty2, ty22, sxs
Dim c As _Unsigned Long
If limit = 0 Then Exit Sub
'carve this!
fEllipse cx, cy, pr, 29 / 35 * pr, &HFFFF5500 ' fill ellipse called with color
lastr = 2 / 7 * pr
If limit = 2 Then
Do
$If WEB Then
G2D.Ellipse cx, cy, lastr, 29 / 35 * pr, 0, &HFF000000
$Else
ellipse cx, cy, lastr, 29 / 35 * pr, &HFF000000
$End If
lastr = .5 * (pr - lastr) + lastr + 1 / 35 * pr
If pr - lastr < 1 / 80 * pr Then Exit Do
Loop
End If
' flickering candle light before sunset
If light < 100 Then
red = Rnd * 55 + 200
red = Rnd * 55 + 200
c = _RGB32(red, red, 0)
Else
c = _RGB32(128, 64, 32)
End If
'Andy Amaya's triangle fill modified for QB64, use if color already set
Sub ftri (xx1, yy1, xx2, yy2, xx3, yy3, c As _Unsigned Long)
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single
Dim slope1 As Single, slope2 As Single, length As Single, x As Single, lastx%, y As Single
Dim slope3 As Single
'make copies before swapping
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then Swap x1, x2: Swap y1, y2
If x3 < x1 Then Swap x1, x3: Swap y1, y3
If x3 < x2 Then Swap x2, x3: Swap y2, y3
If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2 - y1) / length
For x = 0 To length
Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1)), c
lastx% = Int(x + x1)
Next
End If
'draw the second half of the triangle
y = length * slope1 + y1: length = x3 - x2
If length <> 0 Then
slope3 = (y3 - y2) / length
For x = 0 To length
If Int(x + x2) <> lastx% Then
Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2)), c
End If
Next
End If
End Sub
Sub fEllipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long, c As _Unsigned Long)
Dim scale As Single, x As Long, y As Long
scale = yRadius / xRadius
Line (CX, CY - yRadius)-(CX, CY + yRadius), c, BF
For x = 1 To xRadius
y = scale * Sqr(xRadius * xRadius - x * x)
Line (CX + x, CY - y)-(CX + x, CY + y), c
Line (CX - x, CY - y)-(CX - x, CY + y), c
Next
End Sub
Sub ellipse (CX As Long, CY As Long, xRadius As Long, yRadius As Long, c As _Unsigned Long)
Dim scale As Single, xs As Single, x As Single, y As Single
Dim lastx As Single, lasty As Single
scale = yRadius / xRadius: xs = xRadius * xRadius
PSet (CX, CY - yRadius), c: PSet (CX, CY + yRadius), c
lastx = 0: lasty = yRadius
For x = 0 To xRadius
y = scale * Sqr(xs - x * x)
Line (CX + lastx, CY - lasty)-(CX + x, CY - y), c
Line (CX + lastx, CY + lasty)-(CX + x, CY + y), c
Line (CX - lastx, CY - lasty)-(CX - x, CY - y), c
Line (CX - lastx, CY + lasty)-(CX - x, CY + y), c
lastx = x: lasty = y
Next
End Sub
Fall Banner Contest?
