Posts: 476
Threads: 25
Joined: Nov 2022
Reputation:
45
Posts: 3,936
Threads: 175
Joined: Apr 2022
Reputation:
216
Posts: 2,698
Threads: 327
Joined: Apr 2022
Reputation:
217
Make those bats instead of ufos, and it'll fit the hallowtheme better. ?
Posts: 3,936
Threads: 175
Joined: Apr 2022
Reputation:
216
09-06-2023, 11:48 AM
(09-06-2023, 05:05 AM)SMcNeill Wrote: Make those bats instead of ufos, and it'll fit the hallowtheme better. ?
Good idea and I have bats!
I also think I know what is going wrong with ellipse lines in QBJS.
b = b + ...
Posts: 3,936
Threads: 175
Joined: Apr 2022
Reputation:
216
09-07-2023, 03:53 PM
(This post was last modified: 09-07-2023, 04:10 PM by bplus.)
Finally got the ellipse working in QBJS. I only call it to draw the pumpkin but it is good start on using QBJS 2D graphics. Warning until or unless dbox fixes it, don't use Color Statement for coloring graphics with 2d graphics also, for sure it does not work correctly with 2d.ellipse in QBJS.
QB64
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 another attempt to fix ellipse drawing in pumpkin with QBJS
' remove ships.
' To use the 2d ellipse draw function in QBJS because it screws up my QB64
' change color and everything drawn with it old color is changed too.
' Fixed my fTri function with a Color parameter.
$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
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, 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
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
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
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 trunks again
For i = 1 To trees
branch tree(i).x, tree(i).y, tree(i).r, 90, tree(i).h, 0, -1
Next
' hey pumpkin!
_PutImage (690, 80), pumpkinImage, 0
' 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 pumpkin (cx, cy, pr, limit)
Dim As Long u, i
Dim lastr, dx, tx1, tx2, tx3, ty1, ty3, ty2, ty22, sxs
Dim c As _Unsigned Long
'carve this!
fEllipse cx, cy, pr, 29 / 35 * pr, &HFFFF5500
lastr = 2 / 7 * pr
If limit = 2 Then
Do
$If WEB Then
G2D.Ellipse cx, cy, lastr, 29 / 35 * pr, &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
c = _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
' eye sockets
ftri cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, c
ftri cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, c
ftri cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, c
ftri cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, c
' nose
ftri cx, cy - rand&(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand&(1, 2) * pr / 12, cy + 2 * pr / 12, c
' evil grin
ftri cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, c
ftri cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, c
' moving teeth/talk/grrrr..
u = rand&(4, 8)
dx = pr / u
For i = 1 To u
tx1 = cx - 6 * pr / 12 + (i - 1) * dx
tx2 = tx1 + .5 * dx
tx3 = tx1 + dx
ty1 = cy + 5 * pr / 12
ty3 = cy + 5 * pr / 12
ty2 = cy + (4 - Rnd) * pr / 12
ty22 = cy + (6 + Rnd) * pr / 12
ftri tx1, ty1, tx2, ty2, tx3, ty3, c
ftri tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, c
Next
If limit Then
'shifty eyes
If limit = 2 Then sxs = sx Else sxs = .1 * sx
pumpkin sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
pumpkin sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
End If
End Sub
'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 drawShip (x, y, scale, ls, colr As _Unsigned Long) 'shipType collisions same as circle x, y radius = 30
Dim light As Long, r As Long, g As Long, b As Long
r = _Red32(colr): g = _Green32(colr): b = _Blue32(colr)
fEllipse x, y, 6 * scale, 15 * scale, _RGB32(r, g - 120, b - 100)
fEllipse x, y, 18 * scale, 11 * scale, _RGB32(r, g - 60, b - 50)
fEllipse x, y, 30 * scale, 7 * scale, _RGB32(r, g, b)
For light = 0 To 5
fCirc x - 30 * scale + 11 * scale * light + ls, y, 1, _RGB32(ls * 50, ls * 50, ls * 50)
Next
ls = ls + 1
If ls > 5 Then ls = 0
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)
$If WEB Then
y = y + 1
$End If
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
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
Fall Banner fix ellipse in pumpkin
b = b + ...
Posts: 3,936
Threads: 175
Joined: Apr 2022
Reputation:
216
09-07-2023, 07:19 PM
(This post was last modified: 09-07-2023, 08:49 PM by bplus.
Edit Reason: Still cleaning out old ship stuff
)
OK now maybe it's all cleaned up and ellipse fixed for QBJS, slight change with eyes, leave off the recursive call for eye balls in recursive pumpkin's eyes:
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 another attempt to fix ellipse drawing in pumpkin with QBJS
' remove ships.
' To use the 2d ellipse draw function in QBJS because it screws up my QB64
' change color and everything drawn with it old color is changed too.
' Fixed my fTri function with a Color parameter.
$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
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, 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
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
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
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 trunks again
For i = 1 To trees
branch tree(i).x, tree(i).y, tree(i).r, 90, tree(i).h, 0, -1
Next
' hey pumpkin!
_PutImage (690, 80), pumpkinImage, 0
' 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 pumpkin (cx, cy, pr, limit As Integer)
Dim As Long u, i
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
c = _RGB(Rnd * 55 + 200, Rnd * 55 + 200, 120)
' eye sockets
ftri cx - 9 * pr / 12, cy - 2 * pr / 12, cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, c
ftri cx - 7 * pr / 12, cy - 6 * pr / 12, cx - 3 * pr / 12, cy - 0 * pr / 12, cx - 2 * pr / 12, cy - 3 * pr / 12, c
ftri cx + 9 * pr / 12, cy - 2 * pr / 12, cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, c
ftri cx + 7 * pr / 12, cy - 6 * pr / 12, cx + 3 * pr / 12, cy - 0 * pr / 12, cx + 2 * pr / 12, cy - 3 * pr / 12, c
' nose
ftri cx, cy - rand&(2, 5) * pr / 12, cx - 2 * pr / 12, cy + 2 * pr / 12, cx + rand&(1, 2) * pr / 12, cy + 2 * pr / 12, c
' evil grin
ftri cx - 9 * pr / 12, cy + 1 * pr / 12, cx - 7 * pr / 12, cy + 7 * pr / 12, cx - 6 * pr / 12, cy + 5 * pr / 12, c
ftri cx + 9 * pr / 12, cy + 1 * pr / 12, cx + 7 * pr / 12, cy + 7 * pr / 12, cx + 6 * pr / 12, cy + 5 * pr / 12, c
' moving teeth/talk/grrrr..
u = rand&(4, 8)
dx = pr / u
For i = 1 To u
tx1 = cx - 6 * pr / 12 + (i - 1) * dx
tx2 = tx1 + .5 * dx
tx3 = tx1 + dx
ty1 = cy + 5 * pr / 12
ty3 = cy + 5 * pr / 12
ty2 = cy + (4 - Rnd) * pr / 12
ty22 = cy + (6 + Rnd) * pr / 12
ftri tx1, ty1, tx2, ty2, tx3, ty3, c
ftri tx1 + .5 * dx, ty1, tx2 + .5 * dx, ty22, tx3 + .5 * dx, ty3, c
Next
If limit = 2 Then
sxs = sx
pumpkin sxs + cx - 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
pumpkin sxs + cx + 5 * pr / 12, cy - 2.5 * pr / 12, .15 * pr, Int(limit - 1)
End If
End Sub
'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
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
b = b + ...
Posts: 723
Threads: 118
Joined: Apr 2022
Reputation:
106
Looking mighty good! Yeah the pumpkin looks better now. Will the pumpkin just show at Halloween time or all fall?
- Dav
Posts: 3,936
Threads: 175
Joined: Apr 2022
Reputation:
216
(09-07-2023, 08:57 PM)Dav Wrote: Looking mighty good! Yeah the pumpkin looks better now. Will the pumpkin just show at Halloween time or all fall?
- Dav
Hmm... I was thinking the whole time but maybe we could carve it week by week?
I think some other Easter Egg for Halloween maybe bats? maybe other spirits?
b = b + ...
Posts: 3,936
Threads: 175
Joined: Apr 2022
Reputation:
216
Posts: 272
Threads: 24
Joined: Apr 2022
Reputation:
59
Very cool. We're going to cancel each other out cause I'm voting for you.
|
