Playing with dragon curve fractal

'dragoncurve.bas 'A play on a dragon curve fractal 'Adapted by Dav, OCT/2023 Screen _NewImage(800, 600, 32) Dim Shared a, p: p = .001 Do Cls: dragon 400, 300, 90 + (a * 3), a, 16 If a < 200 Then a = a + .15 If p < .002 Then p = p + .00000001 _Limit 15: _Display Loop Until _KeyHit Sub dragon (x, y, size, ang, depth) If depth < 1 Then PSet (x, y), _RGBA(50, 150, 255, 50 + Rnd * 200) Else size2 = size / 1.414214: ang2 = ang - _Pi / p dragon x, y, size2, ang + _Pi / p, depth - 1 dragon x + size2 * Cos(ang), y + size2 * Sin(ang), size2, ang2, depth - 1 End If End Sub

'dragoncurve.bas - v2 'A play on a dragon curve fractal 'Adapted by Dav, OCT/2023 'v2 - New keyboard control. Press +/- to zoom, SPACE resets, ESC ends. Screen _NewImage(800, 600, 32) Dim Shared p As Double: p = Rnd: size = 200 Do Cls: dragon 400, 300, size, a, 15 Select Case Inp(&H60) Case 13: If size < 1200 Then size = size + 5 Case 12: If size > 25 Then size = size - 5 Case 57: p = Rnd Case 1: Exit Do End Select _Limit 15: _Display a = a + .15: p = p + .001 Loop Sub dragon (x, y, size, ang, depth) If depth < 1 Then 'PSet (x, y), _RGBA(50, 150, 255, 50 + Rnd * 200) Circle (x, y), size / 3, _RGBA(50, 150, 255, 50 + Rnd * 200) Else size2 = size / Sqr(2): ang2 = ang - _Pi / p dragon x, y, size2, ang + _Pi / p, depth - 1 dragon x + size2 * Cos(ang), y + size2 * Sin(ang), size2, ang2, depth - 1 End If End Sub

Code: (Select All)

_Title "BodyTree Rework 2020-08" 'b+ 2020-08-14

'BodyTree recur fill.bas for SmallBASIC [B+=MGA] 2016-06-20

'copied and translated from body tree by PeterMaria

'2016-06-20 even more color mods including using triangle fills

' 2020-08-11 trans to QB64

' 2020-08-14 rework the recursive sub so can flex the body tree



Const xmax = 1200, ymax = 700



Screen _NewImage(xmax, ymax, 32)

_Delay .25

_ScreenMove _Middle





Dim Shared limit, ra

limit = 14

ra = _Pi / -4 '45 degrees is standard angle for roof



'sky

Color 0, _RGB32(40, 100, 180): Cls



'the hill for tree

ax0 = xmax / 2 - ymax / 10

ay0 = ymax - 40

bx0 = xmax / 2 + ymax / 10





For ra = 0 To _Pi / 3.7 Step _Pi / 64

    Cls

    level = 0

    'hill

    For r = xmax / 1.5 To 2 * xmax / 15 Step -10

        EllipseFill xmax / 2, ay0, r, .15 * r, _RGB32(0, r / 5, 0)

        'circle , .1, rgb(0, r / 5, 0) filled

    Next



    'tree

    BodyTree ax0, ay0, bx0, ay0, level

    _Display

    _Limit 5

Next

Sleep



Sub BodyTree (x1, y1, x2, y2, level)

    'dim shared ra = roof angle 0 to PI/4

    L = _Hypot(x2 - x1, y2 - y1)

    pa = _Atan2(y2 - y1, x2 - x1) - _Pi / 2 'perpendicular angle to base line

    x3 = x1 + L * 1 * Cos(pa)

    y3 = y1 + L * 1 * Sin(pa)

    x4 = x2 + L * 1 * Cos(pa)

    y4 = y2 + L * 1 * Sin(pa)

    'build roof to square

    mx = (x3 + x4) / 2

    my = (y3 + y4) / 2

    adj = _Hypot(x3 - mx, y3 - my)

    raise = Tan(ra) * adj

    x5 = mx + raise * Cos(pa)

    y5 = my + raise * Sin(pa)



    'now that we have our drawing points draw our house

    'LINE (x2, y2)-(x1, y1), &HFFFFFFFF 'house base

    'LINE (x1, y1)-(x3, y3), &HFFFFFFFF ' left wall

    'LINE (x3, y3)-(x5, y5), &HFFFFFFFF 'left peak

    'LINE (x5, y5)-(x4, y4), &HFFFFFFFF ' right peak

    'LINE (x4, y4)-(x2, y2), &HFFFFFFFF ' right wall completes house



    k = _RGB32((15 - level) * 8, 64 + level * 8, .25 * (15 - level) * 12, 255 - level * 18)

    'k = &HFFBB8866

    ftri x1, y1, x2, y2, x3, y3, k

    ftri x2, y2, x3, y3, x4, y4, k

    ftri x3, y3, x4, y4, x5, y5, k



    If level < limit Then

        BodyTree x3, y3, x5, y5, level + 1

        BodyTree x5, y5, x4, y4, level + 1

    End If

End Sub





Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)

    Dim D As Long

    Static a&

    D = _Dest

    If a& = 0 Then a& = _NewImage(1, 1, 32)

    _Dest a&

    _DontBlend a& '  '<<<< new 2019-12-16 fix

    PSet (0, 0), K

    _Blend a& '<<<< new 2019-12-16 fix

    _Dest D

    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)

End Sub



Sub EllipseFill (CX As Integer, CY As Integer, a As Integer, b As Integer, C As _Unsigned Long)

    ' CX = center x coordinate

    ' CY = center y coordinate

    '  a = semimajor axis

    '  b = semiminor axis

    '  C = fill color

    If a = 0 Or b = 0 Then Exit Sub

    Dim h2 As _Integer64

    Dim w2 As _Integer64

    Dim h2w2 As _Integer64

    Dim x As Integer

    Dim y As Integer

    w2 = a * a

    h2 = b * b

    h2w2 = h2 * w2

    Line (CX - a, CY)-(CX + a, CY), C, BF

    Do While y < b

        y = y + 1

        x = Sqr((h2w2 - y * y * w2) \ h2)

        Line (CX - x, CY + y)-(CX + x, CY + y), C, BF

        Line (CX - x, CY - y)-(CX + x, CY - y), C, BF

    Loop

End Sub

Screen _NewImage(800, 600, 32) tree 400, 600, -90, 100, 0: Sleep Sub tree (x1, y1, angle, size, depth) If depth <= 14 Then x2 = x1 + size * Cos(angle * _Pi / 180) y2 = y1 + size * Sin(angle * _Pi / 180) k& = _RGB32((15 - depth) * 8, 64 + depth * 8, .25 * (15 - depth) * 12, 255 - depth * 18) Line (x1, y1)-(x2, y2), k&: PSet (x1, y1), _RGBA(255, 255, 0, Rnd * 75) tree x2, y2, angle - (Rnd * 35), size * .8, depth + 1 tree x2, y2, angle + (Rnd * 35), size * .8, depth + 1 End If End Sub