Nonsense Forest

[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.

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