09-03-2022, 09:22 PM
(This post was last modified: 09-03-2022, 09:27 PM by James D Jarvis.)
I got inspired by other folks tree programs and decided to spend part of my birthday making one to share.
Mostly new code aside from a few subs I may or may not have shared in the past.
Mostly new code aside from a few subs I may or may not have shared in the past.
Code: (Select All)
'nonsense_forest
'it's my birthday so I made some fun colorful code to share
'
'$dynamic
Screen _NewImage(1000, 600, 32)
_Title "Nonsense Forest - Press any key for another forest - Esc to end"
Randomize Timer
Dim Shared rootx, trunkl, twidth
Dim bx(0, 0) As Integer, by(0, 0) As Integer, bwid(0) As Integer, blen(0) As Integer
Do
_Limit 20
Cls
skyr = 200 - Rnd * (20): skyg = 220 - Rnd * 20: skyb = 255 - Rnd * 20
For y = 0 To _Height * .65
Line (0, y)-(_Width, y), _RGB32(skyr, skyg, skyb)
skyr = skyr - .5: skyg = skyg - .25: skyb = skyb - .12
Next y
grr = 20 + Rnd * 10: grg = 20 + Rnd * 10: grb = 20 + Rnd * 20
For y = _Height * .648 To _Height
Line (0, y)-(_Width, y), _RGB32(grr, grg, grb)
grr = grr - .5: grg = grg + 1: grb = grb + .2
Next y
rootx = 0
rooty = _Height * .67
trees = Int(12 + Rnd * 36)
'trees = 3
For treecount = 1 To trees
branch = Int(2 + Rnd * 8)
' Do
' _Limit 20
' Input "branch stages ? (2 to 12) ", branch
'Loop Until branch > 1 And branch < 13
ReDim bx(branch, 2 ^ branch) As Integer
ReDim by(branch, 2 ^ branch) As Integer
ReDim bwid(branch)
ReDim blen(branch)
rootx = rootx + 12 + (Rnd * 24) * 10
If rootx > _Width * .9 Then
rootx = _Width * .1 + Rnd * 10
rooty = rooty + _Height * .1 + Rnd * 24
End If
rooty = rooty + Rnd * 5 - Rnd * 5
twid = Int((8 + Rnd * 10) / 2)
trunk = _Height / (branch + 10)
bx(1, 1) = rootx
by(1, 1) = rooty - trunk
bwid(1) = twid
blen(1) = trunk
klr = _RGB32(50 + Rnd * 200, 100 + Rnd * 150, 100 + Rnd * 150)
bumpyline rootx, rooty, bx(1, 1), by(1, 1), bwid(1), klr
For n = 2 To branch
bwid(n) = bwid(n - 1) * .75
If bwid(n) < 0.5 Then bwid(n) = 0.5
blen(n) = blen(n - 1) / 2 + Rnd * (blen(n - 1) * .75)
If blen(n) < trunk * .2 Then blen(n) = trunk
For b = 1 To 2 ^ (n - 1)
x1 = bx(n - 1, (b + 1) \ 2)
y1 = by(n - 1, (b + 1) \ 2)
If b Mod 2 = 0 Then
x2 = x1 + blen(n - 1) / 2 + Rnd * blen(n)
Else
x2 = x1 - blen(n - 1) / 2 - Rnd * blen(n)
End If
y2 = y1 - (blen(n) / 2 + Rnd * blen(n))
bx(n, b) = x2
by(n, b) = y2
If b > 1 Then
If bx(n, b) = bx(n, b - 1) And by(n, b) = by(n, b - 1) Then
If bx(n, b) > rootx Then
bx(n, b) = bx(n, b) + blen(n - 1) / 4 + Rnd * blen(n - 1)
by(n, b) = by(n, b) + blen(n - 1) / 4 + Rnd * blen(n - 1)
Else
bx(n, b) = bx(n, b) - blen(n - 1) / 4 + Rnd * blen(n - 1)
by(n, b) = by(n, b) + blen(n - 1) / 4 + Rnd * blen(n - 1)
End If
End If
End If
Next b
Next n
fr = Int(1 + Rnd * 200): fg = Int(1 + Rnd * 200): fb = Int(1 + Rnd * 200)
x1 = bx(branch, 1): x2 = bx(branch, 2 ^ branch)
'Print x1, x2
y1 = by(branch, 2): y2 = by(branch, 2 ^ branch)
avX = (x1 + x2) / 2: avy = (y1 + y2) / 2
' For t = 1 To branch * 3
'polyT avX, avy, Int(10 + Rnd * 50), _RGB32(fr + Int(Rnd * 12), fg + Int(Rnd * 12), fb + Int(Rnd * 12)), Int(31 + Rnd * 140)
' Next t
jagmuch = Int(Rnd * 5)
jagx = Int(3 + Rnd * 10)
jagy = Int(3 + Rnd * 10)
For n = 1 To branch - 1
For b = 1 To 2 ^ (n - 1)
If n = branch - 1 Then
polyT bx(n + 1, b * 2 - 1), by(n + 1, b * 2 - 1), bwid(n) * 10 + Rnd * (bwid(n) * 5), _RGB32(fr + Rnd * 30, fg + Rnd * 30, fb + Rnd * 30), Int(11 + Rnd * 140)
polyT bx(n + 1, b * 2), by(n + 1, b * 2), bwid(n) * 10 + Rnd * (bwid(n) * 5), _RGB32(fr + Rnd * 30, fg + Rnd * 30, fb + Rnd * 30), Int(11 + Rnd * 140)
End If
If jagmuch < 2 Then
bumpyline bx(n, b), by(n, b), bx(n + 1, b * 2 - 1), by(n + 1, b * 2 - 1), bwid(n), klr
bumpyline bx(n, b), by(n, b), bx(n + 1, b * 2), by(n + 1, b * 2), bwid(n), klr
Else
jx = bx(n, b)
jy = by(n, b)
For j = 2 To jagmuch
jx2 = jx + Int(Rnd * jagx) - Int(Rnd * jagx)
jy2 = jy + Int(Rnd * jagy) / 2 - Int(Rnd * jagy)
bumpyline jx, jy, jx2, jy2, bwid(n), klr
jy = jy2
jx = jx2
Next j
bumpyline jx, jy, bx(n + 1, b * 2 - 1), by(n + 1, b * 2 - 1), bwid(n), klr
jx = bx(n, b)
jy = by(n, b)
For j = 2 To jagmuch
jx2 = jx + Int(Rnd * jagx) - Int(Rnd * jagx)
jy2 = jy + Int(Rnd * jagy) / 2 - Int(Rnd * jagy)
bumpyline jx, jy, jx2, jy2, bwid(n), klr
jy = jy2
jx = jx2
Next j
bumpyline jx, jy, bx(n + 1, b * 2), by(n + 1, b * 2), bwid(n), klr
End If
If n = branch - 1 Then
cxa = bx(n + 1, b * 2 - 1)
cya = by(n + 1, b * 2 - 1)
cxb = bx(n + 1, b * 2)
cyb = by(n + 1, b * 2)
tuftlim = Int(12 + Rnd * 12)
For tufts = 3 To tuftlim
cx = cxa + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
cy = cya + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
rf = fr + Int(Rnd * 30): gf = fg + Int(Rnd * 30): bf = fb + Int(Rnd * 30)
If cx > bx(n + 1, b) Then
rf = rf + 10
gf = gf + 20
bf = bf + 10
End If
r = 12 + Rnd * (bwid(n) * 5)
' circleBF cx, cy, r, _RGB32(rf, gf, bf)
polyT cx, cy, r, _RGB32(rf, gf, bf), Int(31 + Rnd * 140)
Next
For tufts = 3 To tuftlim
cx = cxb + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
cy = cyb + Rnd * (bwid(n) * 8) - Rnd * (bwid(n) * 8)
rf = fr + Int(Rnd * 30): gf = fg + Int(Rnd * 30): bf = fb + Int(Rnd * 30)
If cx > bx(n + 1, b) Then
rf = rf + 10
gf = gf + 20
bf = bf + 10
End If
r = 12 + Rnd * (bwid(n) * 5)
'circleBF cx, cy, r, _RGB32(rf, gf, bf)
polyT cx, cy, r, _RGB32(rf, gf, bf), Int(31 + Rnd * 140)
Next
End If
Next b
Next n
Next treecount
Do
_Limit 20
ask$ = InKey$
Loop Until ask$ <> ""
Loop Until ask$ = Chr$(27)
Sub bumpyline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
bumpylineLow x1, y1, x0, y0, r, klr
Else
bumpylineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
bumpylineHigh x1, y1, x0, y0, r, klr
Else
bumpylineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub bumpylineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
nr = r + (1 * Rnd * (r / 2)) - (1 * Rnd(r / 2))
circleBF x, y, nr, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub bumpylineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
nr = r + (1 * Rnd * (r / 2)) - (1 * Rnd(r / 2))
circleBF x, y, nr, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
rsqrd = r * r
y = -r
While y <= r
x = Sqr(rsqrd - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
y = y + 1
Wend
End Sub
Sub polyT (cx As Long, cy As Long, r As Long, klr As _Unsigned Long, deg As Long)
setklr klr
d = 0
x = r * Sin(0)
y = r * Cos(0)
While d < 360
d = d + deg
x2 = r * Sin(0.01745329 * d)
y2 = r * Cos(0.01745329 * d)
_MapTriangle (0, 2)-(2, 2)-(2, 0), pk& To(cx, cy)-(cx + x, cy + y)-(cx + x2, cy + y2)
x = x2
y = y2
Wend
End Sub
Sub setklr (klr As Long)
_Dest pk&
Line (0, 0)-(2, 2), klr, BF
_Dest 0
End Sub
