« previous next »
Pages: 1 [2]   Go Down

Author Topic: Fractals! : Part 2  (Read 24518 times)

0 Members and 1 Guest are viewing this topic.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Fractals! : Part 2
« Reply #15 on: February 17, 2021, 12:01:45 pm »
Quote from: Bolee on February 17, 2021, 05:48:36 am
Cant get to Fractals part 1.


I have made some fractals in VB6 which I will try to convert to QB64. (Made fern, circle fractal, pythagoras tree, binary tree)

Sure! Here is the Platinum Edition:
Code: QB64: [Select]
  1. _Title "Ashish Fractals Plus! mods by bplus 2017-10-19, press space to return to menu"
  3. Dim Shared lowX, highX, lowY, highY
  4.  
  6.     Screen 0
  7.     Cls
  8.     cp 2, "Fractal Menu:"
  9.     lp 4, 25, " 1 Circle"
  10.     lp 5, 25, " 2 Arc"
  11.     lp 6, 25, " 3 Tree"
  12.     lp 7, 25, " 4 Quad"
  13.     lp 8, 25, " 5 Quad & Circle"
  14.     lp 9, 25, " 6 Squares forming triangle"
  15.     lp 10, 25, " 7 Sierpinski Carpet"
  16.     lp 11, 25, " 8 Kite"
  17.     lp 12, 25, " 9 Dragon"
  18.     lp 13, 25, "10 Triangle of Circles"
  19.     lp 14, 25, "11 Vicsek"
  20.     lp 15, 25, "12 Circle Illusion?"
  21.     lp 16, 25, "13 Sierpinski Triangle"
  22.     lp 17, 25, "14 Plus, another variation"
  23.     lp 18, 25, "15 Sierpinski Fies a Kite"
  24.     lp 20, 25, "16 Exit"
  25.     Locate 22, 20
  26.     Input "Enter the menu number of your choice "; menu
  27.  
  28.     Select Case menu
  29.         Case 1: CircleFrac
  30.         Case 2: arcFrac
  31.         Case 3: treeFrac
  32.         Case 4: quadFrac
  33.         Case 5: qncFrac
  34.         Case 6: tnsFrac
  35.         Case 7: sierCarFrac
  36.         Case 8: KiteFrac
  37.         Case 9: dragonFrac
  38.         Case 10: TofCsFrac
  39.         Case 11: VicsekFrac
  40.         Case 12: cIllusFrac
  41.         Case 13: SierTriFrac
  42.         Case 14: PlusFrac
  43.         Case 15: SierFliesKiteFrac
  44.         Case 16: End
  45.     End Select
  47.  
  48. Sub arcFrac
  49.     Screen _NewImage(800, 600, 32)
  50.     r = 40
  51.     needUpdate = 1
  52.     Do
  53.         If _KeyDown(32) Then Exit Sub
  54.         If _KeyDown(Asc("w")) Then r = r + s: needUpdate = 1
  55.         If _KeyDown(Asc("s")) And r > 2 Then r = r - s: needUpdate = 1
  56.         If needUpdate = 1 Then
  57.             needUpdate = 0
  58.             ttl "Arc Fractal, Press 'w' and 's' to zoom-in and zoom-out, space to return to Menu"
  59.             drawArc 400, 300, r, 1
  60.             _Display
  61.             Cls
  62.         End If
  63.         _Limit 60
  64.         s = map(r, 1, 10000, 1, 300)
  65.     Loop
  67.  
  68. Sub CF (x, y, r)
  69.     Circle (x, y), r
  70.     If r > 2 Then
  71.         CF x + r, y, r / 2
  72.         CF x - r, y, r / 2
  73.     End If
  75.  
  76. Sub cIll (x, y, r)
  77.     Line (x, y)-(x - r, y)
  78.     Line (x, y)-(x + r, y)
  79.     Line (x, y)-(x, y - r)
  80.     Line (x, y)-(x, y + r)
  81.     If r > 21 Then
  82.         cIll (x - r) + r / 3, y, r / 2
  83.         cIll (x + r) - r / 3, y, r / 2
  84.         cIll x, (y + r) - r / 3, r / 2
  85.         cIll x, (y - r) + r / 3, r / 2
  86.     End If
  88.  
  89. Sub cIllusFrac
  90.     'Coded By Ashish with <3
  91.     'Can you observe circle in this fractal!? (no, sorry)
  92.     'I was able to do so... :D
  93.     Screen _NewImage(800, 600, 32)
  94.     cIll 400, 300, 200
  95.     ttl "Circle with 4 line variation, Illusion? press any..."
  96.     _Display
  97.     Sleep
  99.  
  100. Sub CircleFrac
  101.     'Idea from  [youtube]https://youtu.be/jPsZwrV9ld0[/youtube]
  102.     Screen _NewImage(800, 600, 32)
  103.     r = 50
  104.     needUpdate = 1
  105.     Do
  106.         If _KeyDown(32) Then Exit Sub
  107.         If _KeyDown(Asc("w")) Then r = r + s: needUpdate = 1
  108.         If _KeyDown(Asc("s")) And r > 2 Then r = r - s: needUpdate = 1
  109.         If needUpdate = 1 Then
  110.             needupadte = 0
  111.             ttl "Circle Fractal, Press 'w' and 's' to zoom-in and zoom-out, space to return to Menu"
  112.             CF 400, 300, r
  113.             _Display
  114.             Cls
  115.         End If
  116.         s = map(r, 1, 10000, 1, 300)
  117.         _Limit 60
  118.     Loop
  120.  
  121. Sub cp (r%, txt$)
  122.     Locate r%, (80 - Len(txt$)) / 2: Print txt$
  124.  
  125. 'Calculate the distance between two points.
  126. Function dist! (x1!, y1!, x2!, y2!)
  127.     dist! = Sqr((x2! - x1!) ^ 2 + (y2! - y1!) ^ 2)
  129.  
  130. Sub dragonFrac
  131.     Screen _NewImage(800, 600, 32)
  132.     drawDragon 400, 300, 400, 300, 60, Rnd * _Pi(2), Rnd * 255, Rnd * 255, Rnd * 255
  133.     ttl "Dragon Curve Fractal, press any except space for more..."
  134.     _Display
  135.     Sleep
  136.     Do
  137.         If _KeyDown(32) Then Exit Sub
  138.         xx = Rnd * _Width
  139.         yy = Rnd * _Height
  140.         drawDragon xx, yy, xx, yy, 60, Rnd * _Pi(2), Rnd * 255, Rnd * 255, Rnd * 255 ': f = 0
  141.         Line (0, 0)-(_Width, _Height), _RGBA(0, 0, 0, 30), BF
  142.         f = f + 1
  143.         ttl "Dragon Curve Fractal, press space to exit"
  144.         _Display
  145.         _Limit 60
  146.     Loop
  148.  
  149. Sub drawArc (x, y, r, f)
  150.     If f = 1 Then
  151.         Circle (x, y), r, , 0, _Pi
  152.     Else
  153.         Circle (x, y), r, , _Pi, _Pi(2)
  154.     End If
  155.     If r > 2 Then
  156.         If f = 1 Then e = 0 Else e = 1
  157.         drawArc x + r, y, r / 2, e
  158.         drawArc x - r, y, r / 2, e
  159.     End If
  161.  
  162. Sub drawDragon (cx, cy, x, y, r, a, mR, mG, mB)
  163.     d = dist(x, y, cx, cy)
  164.     Color _RGB(map(d, 0, 200, mR, 0), map(d + y, y, d + y, 0, mG), map(d, 0, 200, 0, mB))
  165.     fcirc x, y, r
  166.     If r > 1 Then
  167.         drawDragon cx, cy, x + r * 1.75 * Cos(a), y + r * 1.75 * Sin(a), r * 0.75, a - 0.62, mR, mG, mB
  168.         drawDragon cx, cy, x + r * 1.75 * Cos(a + _Pi), y + r * 1.75 * Sin(a + _Pi), r * 0.75, (a + _Pi) - 0.62, mR, mG, mB ')+_PI
  169.     End If
  171.  
  172. Sub drawKite (x, y, s, a)
  173.     Line (x, y)-(x + s * Cos(_Pi(2) - a), (y - s) + s * Sin(_Pi(2) - a))
  174.     Line (x, y)-(x + s * Cos(_Pi + a), (y - s) + s * Sin(_Pi + a))
  175.     If s > 1 Then
  176.         drawKite x + s * Cos(_Pi(2) - a), (y - s) + s * Sin(_Pi(2) - a), s / 2, a
  177.         drawKite x + s * Cos(_Pi + a), (y - s) + s * Sin(_Pi + a), s / 2, a
  178.     End If
  180.  
  181. Sub drawKite2 (xx, yy, s, a)
  182.     x = xx: y = yy
  183.     x2 = x + 3 * s * Cos(_Pi(1 / 2) - a / 2): y2 = y + 3 * s * Sin(_Pi(1 / 2) - a / 2)
  184.     x3 = x + 3 * s * Cos(_Pi(1 / 2) + a / 2): y3 = y + 3 * s * Sin(_Pi(1 / 2) + a / 2)
  185.     SierLineTri x, y, x2, y2, x3, y3, 0
  186.     If s > 10 Then
  187.         drawKite2 x + 1 * s * Cos(_Pi(2) - a), (y - s) + 1 * s * Sin(_Pi(2) - a), s / 2, a
  188.         drawKite2 x + 1 * s * Cos(_Pi + a), (y - s) + 1 * s * Sin(_Pi + a), s / 2, a
  189.     End If
  191.  
  192. Sub drawTree (x, y, r, a, s)
  193.     If r < 14 Then c~& = _RGB(10, 200, 10) Else c~& = _RGB(160, 10, 10)
  194.     internalp5line x, y, x + r * Cos(a - s), y + r * Sin(a - s), r / 10, c~&
  195.     internalp5line x, y, x + r * Cos(a + s * 3), y + r * Sin(a + s * 3), r / 10, c~&
  196.     If r > 2 Then
  197.         drawTree x + r * Cos(a - s), y + r * Sin(a - s), r * 0.67, a - s, s
  198.         drawTree x + r * Cos(a + s * 3), y + r * Sin(a + s * 3), r * 0.67, a + s * 3, s
  199.     End If
  201.  
  202. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
  203. Sub fcirc (CX As Long, CY As Long, R As Long)
  204.     Dim subRadius As Long, RadiusError As Long
  205.     Dim X As Long, Y As Long
  206.     subRadius = Abs(R)
  207.     RadiusError = -subRadius
  208.     X = subRadius
  209.     Y = 0
  210.     If subRadius = 0 Then PSet (CX, CY): Exit Sub
  211.     ' Draw the middle span here so we don't draw it twice in the main loop,
  212.     ' which would be a problem with blending turned on.
  213.     Line (CX - X, CY)-(CX + X, CY), , BF
  214.     While X > Y
  215.         RadiusError = RadiusError + Y * 2 + 1
  216.         If RadiusError >= 0 Then
  217.             If X <> Y + 1 Then
  218.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), , BF
  219.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), , BF
  220.             End If
  221.             X = X - 1
  222.             RadiusError = RadiusError - X * 2
  223.         End If
  224.         Y = Y + 1
  225.         Line (CX - X, CY - Y)-(CX + X, CY - Y), , BF
  226.         Line (CX - X, CY + Y)-(CX + X, CY + Y), , BF
  227.     Wend
  229.  
  230. 'taken from QB64's p5.js
  231. 'http://bit.ly/p5jsbas
  232. Sub internalp5line (x0!, y0!, x1!, y1!, s!, col~&)
  233.     dx! = x1! - x0!
  234.     dy! = y1! - y0!
  235.     d! = Sqr(dx! * dx! + dy! * dy!)
  236.     For i = 0 To d!
  237.         Color col~&
  238.         fcirc x0! + dxx!, y0! + dyy!, s!
  239.         dxx! = dxx! + dx! / d!
  240.         dyy! = dyy! + dy! / d!
  241.     Next
  243.  
  244. Sub KiteFrac
  245.     Screen _NewImage(800, 600, 32)
  246.     ttl "Kite Fractal, press any"
  247.     drawKite 400, 500, 140, .5
  248.     _Display
  249.     Sleep
  251.  
  252. Sub lp (r%, c%, txt$)
  253.     Locate r%, c%: Print txt$
  255.  
  256. 'taken from QB64's p5.js
  257. 'http://bit.ly/p5jsbas
  258. Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
  259.     map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
  261.  
  262. Sub Plus (x, y, r)
  263.     'variation BF, B, B, BF
  264.     'variation #2 BF, BF, BF, BF
  265.     'variation #3 B, B, B, B
  266.     'How many plus can you find?
  267.     Color _RGB(r, 255 - r, 255 - r)
  268.     Line (x, y)-(x - r, y - r), , BF
  269.     Line (x, y)-(x + r, y - r), , B
  270.     Line (x, y)-(x - r, y + r), , B
  271.     Line (x, y)-(x + r, y + r), , BF
  272.     If r > 6 Then
  273.         Plus x - r / 2, y - r / 2, r / 2.3
  274.         Plus x + r / 2, y - r / 2, r / 2.3
  275.         Plus x - r / 2, y + r / 2, r / 2.3
  276.         Plus x + r / 2, y + r / 2, r / 2.3
  277.     End If
  279.  
  280. Sub PlusFrac
  281.     'playing with Ashish circle with 4 line by bplus 2017-10-16
  282.     Screen _NewImage(800, 600, 32)
  283.     Plus 400, 300, 290
  284.     ttl "Plus, another variation "
  285.     _Display
  286.     Sleep
  288.  
  289. Sub qncFrac
  290.     Screen _NewImage(800, 600, 32)
  291.     r = 100
  292.     needupdate = 1
  293.     Do
  294.         If _KeyDown(32) Then Exit Sub
  295.         If _KeyDown(Asc("w")) Then r = r + s: needupdate = 1
  296.         If _KeyDown(Asc("s")) And r > 2 Then r = r - s: needupdate = 1
  297.         If needupdate = 1 Then
  298.             needupdate = 0
  299.             ttl "Quad Inside Circle Inside Quad, press w to widen, s to shrink, space to exit"
  300.             quad_circle 400, 300, 0, 0, r, 0
  301.             _Display
  302.             Cls
  303.             s = map(r, 1, 10000, 1, 300)
  304.         End If
  305.         _Limit 40
  306.     Loop
  308.  
  309. Sub quad_circle (x, y, x2, y2, r, e)
  310.     If e = 1 Then
  311.         Line (x, y)-(x2, y2), , B
  312.     Else
  313.         Circle (x, y), r
  314.     End If
  315.     If r > 2 Then
  316.         If e = 1 Then
  317.             If x2 > x Then newR = x2 - x Else newR = x - x2
  318.             quad_circle (x + x2) / 2, (y + y2) / 2, 0, 0, newR / 2, 0
  319.         Else
  320.             tx1 = x + r * Cos(_Pi - .7)
  321.             ty1 = y + r * Sin(_Pi - .7)
  322.             tx2 = x + r * Cos(_Pi(2) - .7)
  323.             ty2 = y + r * Sin(_Pi(2) - .7)
  324.             quad_circle tx1, ty1, tx2, ty2, r / 2, 1
  325.         End If
  326.     End If
  328.  
  329. Sub quad_fractal (x, y, r, e)
  330.     If _KeyDown(32) Then Exit Sub
  331.     Line (x - r, y - r)-(x + r, y - r)
  332.     Line (x + r, y - r)-(x + r, y + r)
  333.     Line (x + r, y + r)-(x - r, y + r)
  334.     Line (x - r, y + r)-(x - r, y - r)
  335.     If r > e Then
  336.         quad_fractal x - r, y - r, r / 2, e
  337.         quad_fractal x + r, y - r, r / 2, e
  338.         quad_fractal x + r, y + r, r / 2, e
  339.         quad_fractal x - r, y + r, r / 2, e
  340.     End If
  342.  
  343. Sub quadFrac
  344.     Screen _NewImage(800, 600, 32)
  345.     k = 100: dir = .5
  346.     Do
  347.         If _KeyDown(32) Then Exit Sub
  348.         Cls
  349.         ttl "Quads!!, press space to exit"
  350.         quad_fractal 400, 300, 100, k
  351.         _Display
  352.         _Limit 2
  353.         k = k * dir
  354.         If k < 2 Then dir = 2
  355.         If k > 100 Then dir = .5
  356.     Loop
  358.  
  359. Sub SC (x, y, r)
  360.     Line (x - r, y - r)-(x + r, y + r), _RGB(map(x, lowX, highX, 0, 255), map(y, lowY, highY, 255, 0), map(x + y, lowX + lowY, highX + highY, 255, 0)), BF
  361.     If r > 3 Then
  362.         v = r * 2
  363.         SC x, y - v, r / 3
  364.         SC x, y + v, r / 3
  365.         SC x + v, y, r / 3
  366.         SC x - v, y, r / 3
  367.         SC x - v, y - v, r / 3
  368.         SC x + v, y + v, r / 3
  369.         SC x - v, y + v, r / 3
  370.         SC x + v, y - v, r / 3
  371.     End If
  373.  
  374. Sub SC0 (x, y, r)
  375.     Line (x - r, y - r)-(x + r, y + r), _RGB(0, 0, 0), BF
  376.     If x - r < lowX Then lowX = x - r
  377.     If x + r > highX Then highX = x + r
  378.     If y - r < lowY Then lowY = y - r
  379.     If y + r > highY Then highY = y + r
  380.     If r > 3 Then
  381.         v = r * 2
  382.         SC0 x, y - v, r / 3
  383.         SC0 x, y + v, r / 3
  384.         SC0 x + v, y, r / 3
  385.         SC0 x - v, y, r / 3
  386.         SC0 x - v, y - v, r / 3
  387.         SC0 x + v, y + v, r / 3
  388.         SC0 x - v, y + v, r / 3
  389.         SC0 x + v, y - v, r / 3
  390.     End If
  392.  
  393. Sub sierCarFrac
  394.     Screen _NewImage(1000, 700, 32)
  395.     lowX = 500
  396.     highX = 500
  397.     highY = 500
  398.     lowY = 500
  399.     Cls , _RGB(255, 255, 255)
  400.     SC0 500, 350, 120
  401.     Line (0, 0)-(lowX, _Height), _RGB(0, 0, 0), BF
  402.     Line (_Width - 1, 0)-(highX, _Height), _RGB(0, 0, 0), BF
  403.     Line (0, 0)-(_Width, lowY), _RGB(0, 0, 0), BF
  404.     Line (0, _Height)-(_Width, highY), _RGB(0, 0, 0), BF
  405.     ttl "Sierpinski_Carpet, press any"
  406.     _Display
  407.     Sleep
  408.     SC 500, 350, 120
  409.     ttl "Sierpinski_Carpet, press any"
  410.     _Display
  411.     Sleep
  413.  
  414. Sub SierFliesKiteFrac
  415.     ' after playing with Ashish Kite Fractal,  by bplus 2017-10-16
  416.     Screen _NewImage(1200, 700, 32)
  417.     While 1
  418.         Cls
  419.         If _KeyDown(32) Then Exit Sub
  420.         drawKite2 600, 540, 200, a
  421.         ttl "Sierpinski flies a Kite, press space to exit"
  422.         _Display
  423.         _Limit 20
  424.         a = a + _Pi(2 / 360)
  425.     Wend
  427.  
  428. Sub SierLineTri (x1, y1, x2, y2, x3, y3, depth)
  429.     If depth = 0 Then 'draw out triangle if level 0
  430.         Line (x1, y1)-(x2, y2)
  431.         Line (x2, y2)-(x3, y3)
  432.         Line (x1, y1)-(x3, y3)
  433.     End If
  434.     'find midpoints
  435.     If x2 < x1 Then mx1 = (x1 - x2) / 2 + x2 Else mx1 = (x2 - x1) / 2 + x1
  436.     If y2 < y1 Then my1 = (y1 - y2) / 2 + y2 Else my1 = (y2 - y1) / 2 + y1
  437.     If x3 < x2 Then mx2 = (x2 - x3) / 2 + x3 Else mx2 = (x3 - x2) / 2 + x2
  438.     If y3 < y2 Then my2 = (y2 - y3) / 2 + y3 Else my2 = (y3 - y2) / 2 + y2
  439.     If x3 < x1 Then mx3 = (x1 - x3) / 2 + x3 Else mx3 = (x3 - x1) / 2 + x1
  440.     If y3 < y1 Then my3 = (y1 - y3) / 2 + y3 Else my3 = (y3 - y1) / 2 + y1
  441.     Line (mx1, my1)-(mx2, my2) '  'draw all inner triangles
  442.     Line (mx2, my2)-(mx3, my3)
  443.     Line (mx1, my1)-(mx3, my3)
  444.     If depth < 4 Then 'not done so call me again
  445.         SierLineTri x1, y1, mx1, my1, mx3, my3, depth + 1
  446.         SierLineTri x2, y2, mx1, my1, mx2, my2, depth + 1
  447.         SierLineTri x3, y3, mx3, my3, mx2, my2, depth + 1
  448.     End If
  450.  
  451. Sub SierTri (x, y, r)
  452.     Line (x + r * Cos(_D2R(330)), y + r * Sin(_D2R(330)))-(x + r * Cos(_D2R(90)), y + r * Sin(_D2R(90)))
  453.     Line (x + r * Cos(_D2R(90)), y + r * Sin(_D2R(90)))-(x + r * Cos(_D2R(210)), y + r * Sin(_D2R(210)))
  454.     Line (x + r * Cos(_D2R(210)), y + r * Sin(_D2R(210)))-(x + r * Cos(_D2R(330)), y + r * Sin(_D2R(330)))
  455.     If r > 4 Then
  456.         SierTri x + r * Cos(_D2R(30)), y + r * Sin(_D2R(30)), r / 2
  457.         SierTri x + r * Cos(_D2R(150)), y + r * Sin(_D2R(150)), r / 2
  458.         SierTri x + r * Cos(_D2R(270)), y + r * Sin(_D2R(270)), r / 2
  459.     End If
  461.  
  462. Sub SierTriFrac
  463.     Screen _NewImage(800, 600, 32)
  464.     SierTri 400, 400, 160
  465.     ttl "Sierpinski Triangle, press any..."
  466.     _Display
  467.     Sleep
  469.  
  470. Sub TofCs (x, y, r, t)
  471.     Color _RGB(Rnd * 255, Rnd * 255, Rnd * 255)
  472.     fcirc x, y, r
  473.     If r > 2 Then
  474.         TofCs x + r * 1.75 * Cos(t), y + r * 1.75 * Sin(t), r * 0.75, t
  475.         TofCs x + r * 1.75 * Cos(_Pi + t), y + r * 1.75 * Sin(_Pi - t), r * 0.75, t
  476.     End If
  478.  
  479. Sub TofCsFrac 'modified for speed as Petr had shown
  480.     Screen _NewImage(1000, 600, 32)
  481.     TofCs 500, 200, 80, .5
  482.     ttl "Triangle Formed By Circle, press any..."
  483.     _Display
  484.     Sleep
  486.  
  487. Sub tns (x, y, r)
  488.     Line (x - r, y - r)-(x + r, y + r), _RGB(Rnd * 255, Rnd * 255, Rnd * 255), BF
  489.     If r > 1 Then
  490.         v = r * 2
  491.         tns x, y - v, r / 2
  492.         tns x + v, y - r * 2, r / 2
  493.         tns x + v, y, r / 2
  494.     End If
  496.  
  497. Sub tnsFrac
  498.     ttl "Square_formed_triangle, press any..."
  499.     Screen _NewImage(800, 600, 32)
  500.     tns 250, 450, 100
  501.     _Display
  502.     Sleep
  504.  
  505. Sub treeFrac
  506.     Screen _NewImage(800, 600, 32)
  507.     radius = 130
  508.     Do
  509.         Cls
  510.         ttl "Fractal_Trees, press space to return to Menu"
  511.         If _KeyDown(32) Then Exit Sub
  512.         drawTree 400, 400, radius, _Pi(3 / 2), s
  513.         internalp5line 400, 600, 400, 400, radius / 10, _RGB(160, 10, 10)
  514.         _Display
  515.         _Limit 40
  516.         s = Abs(Sin(v#)) * 0.25 + 0.2
  517.         v# = v# + 0.01
  518.     Loop
  520.  
  521. Sub ttl (txt$)
  522.     Color _RGB(0, 200, 200)
  523.     lp 2, 5, txt$
  524.     Color _RGB(255, 255, 255)
  526.  
  527. Sub vicsek (x, y, r)
  528.     Line (x, y)-(x - r, y)
  529.     Line (x, y)-(x + r, y)
  530.     Line (x, y)-(x, y - r)
  531.     Line (x, y)-(x, y + r)
  532.     If r > 2 Then
  533.         vicsek x - r, y, r / 3
  534.         vicsek x + r, y, r / 3
  535.         vicsek x, y + r, r / 3
  536.         vicsek x, y - r, r / 3
  537.         vicsek x, y, r / 3
  538.     End If
  540.  
  541. Sub VicsekFrac
  542.     Screen _NewImage(800, 600, 32)
  543.     vicsek 400, 300, 180
  544.     ttl "Vicsek Fractal, press any..."
  545.     _Display
  546.     Sleep
  548.  

Platinum because this Edition has Sierpinsky Flies a Kite a mod of Ashish Kite:
 
Sierpinsky Flies a Kite.PNG
« Last Edit: February 17, 2021, 12:05:03 pm by bplus »
Logged
Pages: 1 [2]   Go Up
« previous next »