Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: Ashish on March 15, 2018, 12:33:02 pm

Title: Fractals! : Part 2
Post by: Ashish on March 15, 2018, 12:33:02 pm
Hi everyone! :)
I've again coded  some fractals... This time I've shown some L-System fractal. You can also see my previous
 fractal demos here - www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=14546

1. L-Systems Fractals (Contain 12 L-system fractals)  :)
Code: QB64: [Select]
  1. 'Coded By Ashish in QB64
  2. 'Twiter : @KingOfCoders
  3. _TITLE "Fractals [Part 2 : L-System]"
  4.  
  5. SCREEN _NEWIMAGE(800, 600, 32)
  6.  
  7. TYPE rule_type
  8.     token AS STRING * 1
  9.     replace AS STRING * 256
  11.  
  12.  
  13. DIM SHARED fractalsName(11) AS STRING
  14. DIM SHARED fractalRules(14) AS rule_type
  15.  
  16.  
  17. fractalsName(0) = "Board": fractalRules(0).token = "F": fractalRules(0).replace = "FF+F+F+F+FF"
  18. fractalsName(1) = "Crystal": fractalRules(1).token = "F": fractalRules(1).replace = "FF+F++F+F"
  19. fractalsName(2) = "Peano Curve": fractalRules(2).token = "X": fractalRules(2).replace = "XFYFX+F+YFXFY-F-XFYFX": fractalRules(3).token = "Y": fractalRules(3).replace = "YFXFY-F-XFYFX+F+YFXFY"
  20. fractalsName(3) = "Quadratic Gosper": fractalRules(4).token = "X": fractalRules(4).replace = "XFX-YF-YF+FX+FX-YF-YFFX+YF+FXFXYF-FX+YF+FXFX+YF-FXYF-YF-FX+FX+YFYF-": fractalRules(5).token = "Y": fractalRules(5).replace = "+FXFX-YF-YF+FX+FXYF+FX-YFYF-FX-YF+FXYFYF-FX-YFFX+FX+YF-YF-FX+FX+YFY"
  21. fractalsName(4) = "Quadratic Snowflake": fractalRules(6).token = "F": fractalRules(6).replace = "F-F+F+F-F"
  22. fractalsName(5) = "Quadratic Koch Island": fractalRules(7).token = "F": fractalRules(7).replace = "F-FF+FF+F+F-F-FF+F+F-F-FF-FF+F"
  23. fractalsName(6) = "Square Sierpinski": fractalRules(8).token = "X": fractalRules(8).replace = "XF-F+F-XF+F+XF-F+F-X"
  24. fractalsName(7) = "Triangle": fractalRules(9).token = "F": fractalRules(9).replace = "F-F+F"
  25. fractalsName(8) = "Von Koch Snowflake": fractalRules(10).token = "F": fractalRules(10).replace = "F-F++F-F"
  26. fractalsName(9) = "Hilbert": fractalRules(11).token = "X": fractalRules(11).replace = "-YF+XFX+FY-": fractalRules(12).token = "Y": fractalRules(12).replace = "+XF-YFY-FX+"
  27. fractalsName(10) = "Cross": fractalRules(13).token = "F": fractalRules(13).replace = "F+F-F+F+F"
  28. fractalsName(11) = "Pentaplexity": fractalRules(14).token = "F": fractalRules(14).replace = "F++F++F|F-F++F"
  29.  
  30.  
  32.     choice = getChoice
  33.     IF choice >= 0 AND choice <= UBOUND(fractalsName) THEN
  34.         _TITLE _TITLE$ + " " + fractalsName(choice)
  35.         SELECT CASE choice
  36.             CASE 0
  37.                 g$ = prepareGrammer("F+F+F+F", 0, 0, 5)
  38.                 angle! = 90
  39.             CASE 1
  40.                 g$ = prepareGrammer("F+F+F+F", 1, 1, 5)
  41.                 angle! = 90
  42.             CASE 2
  43.                 g$ = prepareGrammer("X", 2, 3, 4)
  44.                 angle! = 90
  45.             CASE 3
  46.                 g$ = prepareGrammer("-YF", 4, 5, 3)
  47.                 angle! = 90
  48.             CASE 4
  49.                 g$ = prepareGrammer("F", 6, 6, 5)
  50.                 angle! = 90
  51.             CASE 5
  52.                 g$ = prepareGrammer("F+F+F+F", 7, 7, 3)
  53.                 angle! = 90
  54.             CASE 6
  55.                 g$ = prepareGrammer("F+XF+F+XF", 8, 8, 5)
  56.                 angle! = 90
  57.             CASE 7
  58.                 g$ = prepareGrammer("F", 9, 9, 7)
  59.                 angle! = 120
  60.             CASE 8
  61.                 g$ = prepareGrammer("F++F++F", 10, 10, 5)
  62.                 angle! = 60
  63.             CASE 9
  64.                 g$ = prepareGrammer("X", 11, 12, 7)
  65.                 angle! = 90
  66.             CASE 10
  67.                 g$ = prepareGrammer("F+F+F+F", 13, 13, 6)
  68.                 angle! = 90
  69.             CASE 11
  70.                 g$ = prepareGrammer("F++F++F++F++F", 14, 14, 5)
  71.                 angle! = 36
  72.  
  73.         END SELECT
  74.         showControl
  75.         x = 100
  76.         y = 100
  77.         r = 3
  78.         DO
  79.             CLS
  80.  
  81.             IF _KEYDOWN(ASC("w")) THEN y = y - 2
  82.             IF _KEYDOWN(ASC("s")) THEN y = y + 2
  83.             IF _KEYDOWN(ASC("a")) THEN x = x - 2
  84.             IF _KEYDOWN(ASC("d")) THEN x = x + 2
  85.             IF _KEYDOWN(ASC("q")) THEN r = r + .1
  86.             IF _KEYDOWN(ASC("e")) AND r > 1 THEN r = r - .1
  87.             IF _KEYDOWN(27) THEN _AUTODISPLAY: EXIT DO
  88.             drawFractal g$, angle!, r, x, y
  89.  
  90.             _LIMIT 40
  91.             _DISPLAY
  92.  
  93.         LOOP
  94.     ELSE
  95.         PRINT "Wrong Choice"
  96.         _DELAY 1
  97.     END IF
  98.     _KEYCLEAR
  100.  
  101. FUNCTION prepareGrammer$ (axm$, s, e, N)
  102.     DIM fractalRule(e - s) AS rule_type
  103.     FOR i = s TO e
  104.         fractalRule(i - s).token = fractalRules(i).token
  105.         fractalRule(i - s).replace = RTRIM$(fractalRules(i).replace)
  106.     NEXT
  107.     prepareGrammer$ = generateGrammer$(axm$, fractalRule(), N)
  109.  
  110. FUNCTION getChoice ()
  111.     _TITLE "Fractals [Part 2 : L-System]"
  112.     CLS
  113.     FOR i = 0 TO UBOUND(fractalsName)
  114.         PRINT i + 1; ". "; fractalsName(i)
  115.     NEXT
  116.     INPUT "Enter the fractal No. : ", getChoice
  117.     getChoice = getChoice - 1
  119.  
  120. '######################################################
  121. 'Fractal related subroutine
  122. SUB showControl ()
  123.     CLS
  124.     PRINT "Use 'w' and 's' to move up and down"
  125.     PRINT "Use 'a' and 'd' to move left and rigth"
  126.     PRINT "Use 'q' and 'e' to zoom-in and zoom-out"
  127.     PRINT "Use 'Esc' to goto fractal menu"
  128.     PRINT "Hit a Key"
  129.     SLEEP
  131.  
  132. SUB drawFractal (grammer$, ang!, r, x, y)
  133.     ang2! = 0
  134.     px = x
  135.     py = y
  136.     FOR i = 1 TO LEN(grammer$)
  137.         ca$ = MID$(grammer$, i, 1)
  138.         SELECT CASE ca$
  139.             CASE "F"
  140.                 xx = COS(_D2R(ang2!)) * r + px
  141.                 yy = SIN(_D2R(ang2!)) * r + py
  142.                 LINE (px, py)-(xx, yy)
  143.                 px = xx
  144.                 py = yy
  145.             CASE "+"
  146.                 ang2! = ang2! + ang!
  147.             CASE "-"
  148.                 ang2! = ang2! - ang!
  149.             CASE "|"
  150.                 ang2! = ang2! + 180
  151.             CASE "f"
  152.                 xx = COS(_D2R(ang2!)) * r + px
  153.                 yy = SIN(_D2R(ang2!)) * r + py
  154.                 px = xx
  155.                 py = yy
  156.         END SELECT
  157.     NEXT
  159.  
  160. 'L-System Function
  161. FUNCTION generateGrammer$ (axiom$, rule() AS rule_type, n~&)
  162.     axiom2$ = axiom$
  163.     axiom3$ = ""
  164.     DO
  165.         FOR i = 1 TO LEN(axiom2$)
  166.             ca$ = MID$(axiom2$, i, 1)
  167.             nca$ = ca$
  168.             FOR j = 0 TO UBOUND(rule)
  169.                 IF rule(j).token = ca$ THEN
  170.                     nca$ = RTRIM$(rule(j).replace)
  171.                     EXIT FOR
  172.                 END IF
  173.             NEXT
  174.             axiom3$ = axiom3$ + nca$
  175.         NEXT
  176.         axiom2$ = axiom3$
  177.         axiom3$ = ""
  178.         count = count + 1
  179.         PRINT ".";
  180.     LOOP UNTIL count >= n~&
  181.     generateGrammer$ = axiom2$
  183.  
  184.  

2. Christmas Tree  ;)
Code: QB64: [Select]
  1. 'Coded By Ashish
  2. _TITLE "Christmas Tree"
  3. SCREEN _NEWIMAGE(800, 600, 32)
  4. DIM SHARED sx, sy, ox, oy, z
  5. ox = _WIDTH * .2
  6. oy = _HEIGHT * .9
  7. z = 500
  8. COLOR _RGBA(255, 255, 255, 40)
  9. drawChristmasTree 0, 0, 0
  10. FOR i = 0 TO 50
  11.     a = sx: b = sy
  12.     drawChristmasTree a, b, 0
  14.  
  15. SUB drawChristmasTree (x!, y!, N AS _UNSIGNED LONG)
  17.         CASE 0 TO 1 / 3
  18.             xx! = -.5 * y! + .5
  19.             yy! = .5 * x
  20.         CASE 1 / 3 TO 2 / 3
  21.             xx! = .5 * y! + .5
  22.             yy! = -.5 * x + .5
  23.         CASE ELSE
  24.             xx! = .5 * x! + .25
  25.             yy! = .5 * y + .5
  26.     END SELECT
  27.     PSET (xx! * z + ox, -yy! * z + oy)
  28.     IF N < 10000 THEN
  29.         drawChristmasTree xx!, yy!, N + 1
  30.     ELSE sx = xx!: sy = yy!
  31.     END IF
  33.  
  34.  

3. Dragon  :D
Code: QB64: [Select]
  1. 'Coded By Ashish
  2. _TITLE "Dragon"
  3. SCREEN _NEWIMAGE(800, 700, 32)
  4. DIM SHARED sx, sy, ox, oy, z
  5.  
  6. z = 60
  7. ox = _WIDTH * .46
  8. oy = _HEIGHT * .09
  9. COLOR _RGBA(255, 180, 0, 30)
  10. drawDragon 0, 0, 0
  11. FOR i = 0 TO 100
  12.     a = sx: b = sy
  13.     drawDragon a, b, 0
  15. SUB drawDragon (x!, y!, N AS _UNSIGNED LONG)
  17.         CASE 0 TO .8
  18.             xx! = .824074 * x! + .281428 * y! - 1.88229
  19.             yy! = -.212346 * x! + .864198 * y! - .110607
  20.         CASE ELSE
  21.             xx! = .088272 * x! + .520988 * y! + .78536
  22.             yy! = -.463889 * x! - .377778 * y! + 8.095795
  23.     END SELECT
  24.     PSET (xx! * z + ox, yy! * z + oy)
  25.     IF N < 10000 THEN
  26.         drawDragon xx!, yy!, N + 1
  27.     ELSE sx = xx!: sy = yy!
  28.     END IF
  30.  
  31.  

4. Spiral  :)
Code: QB64: [Select]
  1. 'Coded By Ashish in QB64
  2. _TITLE "IFS Spiral"
  3.  
  4. SCREEN _NEWIMAGE(800, 600, 32)
  5.  
  7. DIM SHARED gx, gy
  8. COLOR _RGBA(255, 255, 255, 10)
  9. drawSpiral _WIDTH * .75, _HEIGHT * .25, 1
  10.  
  11. FOR i = 0 TO 100
  12.     vx = gx
  13.     vy = gy
  14.     drawSpiral vx, vy, 1
  16.  
  17.  
  18. SUB drawSpiral (x!, y!, N~&)
  19.     SELECT CASE RND(1)
  20.         CASE 0 TO 0.05
  21.             xx! = -0.121212 * x! + 0.257576 * y! - 6.721654
  22.             yy! = 0.151515 * x! + 0.053030 * y! + 1.377236
  23.         CASE 0.05 TO 0.10
  24.             xx! = 0.181818 * x! - 0.136364 * y! + 6.086107
  25.             yy! = 0.090909 * x! + 0.181818 * y! + 1.568035
  26.         CASE ELSE
  27.             xx! = 0.787879 * x! - 0.424242 * y! + 1.758647
  28.             yy! = 0.242424 * x! + 0.859848 * y! + 1.408065
  29.     END SELECT
  30.     PSET (xx! * 60 + _WIDTH * .5, yy! * 60)
  31.     IF N~& < 10000 THEN
  32.         drawSpiral xx!, yy!, N~& + 1
  33.     ELSE
  34.         gx = xx!
  35.         gy = yy!
  36.     END IF
  38.  
  39.  

5. Old Tree  ;)
Code: QB64: [Select]
  1. 'Coded By Ashish
  2. _TITLE "Old Tree"
  3. SCREEN _NEWIMAGE(800, 600, 32)
  4. DIM SHARED sx, sy, ox, oy, z
  5. ox = _WIDTH * .11 'x-offset
  6. oy = _HEIGHT * 1.1 'y-offset
  7. z = 600 'zoom-value
  8. COLOR _RGBA(255, 255, 255, 40)
  9. drawOldTree 0, 0, 0
  10.  
  11. FOR i = 0 TO 100
  12.     a = sx: b = sy
  13.     drawOldTree a, b, 0
  16. SUB drawOldTree (x!, y!, N AS _UNSIGNED LONG)
  18.         CASE 0 TO .2
  19.             xx! = .195 * x! - .488 * y! + .4431
  20.             yy! = .344 * x! + .443 * y! + .2452
  21.         CASE .2 TO .4
  22.             xx! = .462 * x! + .414 * y! + .2511
  23.             yy! = -.252 * x! + .361 * y! + .5692
  24.         CASE .4 TO .6
  25.             xx! = -.637 * x! + .8562
  26.             yy! = .501 * y! + .2512
  27.         CASE .6 TO .8
  28.             xx! = -.035 * x! + .07 * y! + .4884
  29.             yy! = -.469 * x! + .022 * y! + .5069
  30.         CASE ELSE
  31.             xx! = -.058 * x! - .07 * y! + .5976
  32.             yy! = .453 * x! - .111 * y! + .0969
  33.     END SELECT
  34.     'IF N MOD 1000 = 0 THEN _DELAY .01
  35.     PSET (xx! * z + ox, oy - yy! * (z + z * .25))
  36.     IF N < 10000 THEN
  37.         drawOldTree xx!, yy!, N + 1
  38.     ELSE sx = xx!: sy = yy!
  39.     END IF
  41.  
  42.  

6. Leaf  :D
Code: QB64: [Select]
  1. 'Coded By Ashish in QB64
  2. _TITLE "Leaf"
  3. SCREEN _NEWIMAGE(800, 600, 32)
  4. DIM SHARED sx, sy, ox, oy, z
  6. ox = _WIDTH * .34
  7. oy = _HEIGHT
  8. z = 700
  9. COLOR _RGBA(0, 255, 0, 10)
  10. drawLeaf 0, 0, 0
  12.     p = sx: q = sy
  13.     drawLeaf p, q, 0
  14.     _LIMIT 30
  16.  
  17. SUB drawLeaf (x!, y!, N AS _UNSIGNED LONG)
  18.     DIM a(3) AS SINGLE, b(3) AS SINGLE, c(3) AS SINGLE, d(3) AS SINGLE, e(3) AS SINGLE, f(3) AS SINGLE
  19.     a(0) = 0: a(1) = .7248: a(2) = .1583: a = (3) = .3386
  20.     b(0) = .2439: b(1) = .0337: b(2) = -.1297: b(3) = .3694
  21.     c(0) = 0: c(1) = -.0253: c(2) = .355: c(3) = .2227
  22.     d(0) = .3053: d(1) = .7426: d(2) = .3676: d(3) = -.0756
  23.     e(0) = 0: e(1) = .206: e(2) = .1383: e(3) = .0679
  24.     f(0) = 0: f(1) = .2538: f(2) = .175: f(3) = .0826
  25.     k = INT(RND * 4)
  26.     xx! = a(k) * x! + b(k) * y! + e(k)
  27.     yy! = c(k) * x! + d(k) * y! + f(k)
  28.     PSET (xx! * z + ox, -yy! * z + oy)
  29.  
  30.     IF N < 10000 THEN
  31.         drawLeaf xx!, yy!, N + 1
  32.     ELSE sx = xx!: sy = yy!
  33.     END IF
  35.  
  36.  

7. Young Tree  :)
Code: QB64: [Select]
  1. 'Coded By Ashish in QB64
  2. DEFDBL A-Z
  3. _TITLE "Young Tree"
  4. SCREEN _NEWIMAGE(800, 700, 32)
  5. DIM SHARED sx, sy, ox, oy, z
  6. ox = _WIDTH / 2
  7. oy = _HEIGHT
  8. z = 300
  9. COLOR _RGBA(255, 255, 255, 40)
  10. drawYoungTree 0, 0, 0
  11. FOR i = 0 TO 200
  12.     a = sx: b = sy
  13.     drawYoungTree a, b, 0
  16. SUB drawYoungTree (x, y, N AS _UNSIGNED LONG)
  17.     DIM r(5), s(5), theta(5), phi(5), f(5)
  18.     r(0) = .05: r(1) = .05: r(2) = .6: r(3) = .5: r(4) = .5: r(5) = .55
  19.     s(0) = .6: s(1) = -.5: s(2) = .5: s(3) = .45: s(4) = .55: s(5) = .4
  20.     theta(0) = 0: theta(1) = 0: theta(2) = .698: theta(3) = .349: theta(4) = -.524: theta(5) = -.698
  21.     phi(0) = 0: phi(1) = 0: phi(2) = .698: phi(3) = .3492: phi(4) = -.524: phi(5) = -.698
  22.     f(0) = 0: f(1) = 1: f(2) = .6: f(3) = 1.1: f(4) = 1: f(5) = .7
  23.     k = INT(RND * 6)
  24.     xx = r(k) * COS(theta(k)) * x - s(k) * SIN(phi(k)) * y
  25.     yy = r(k) * SIN(theta(k)) * x + s(k) * COS(phi(k)) * y + f(k)
  26.     PSET (xx * (z + z * .25) + ox, -yy * z + oy)
  27.     IF N < 6000 THEN
  28.         drawYoungTree xx, yy, N + 1
  29.     ELSE sx = xx: sy = yy
  30.     END IF
  32.  
  33.  
Title: Re: Fractals! : Part 2
Post by: bplus on March 15, 2018, 10:32:46 pm
Very nice set of fractals!
Title: Re: Fractals! : Part 2
Post by: Ashish on March 16, 2018, 03:21:06 am
Quote from: bplus on March 15, 2018, 10:32:46 pm
Very nice set of fractals!
Thanks bplus! :)
Title: Re: Fractals! : Part 2
Post by: _vince on March 16, 2018, 05:12:03 am
Nice use of recursion, very suitable to the nature of fractals.  Here's a program I found of a similar style

Code: QB64: [Select]
  4. pi = 4*atn(1)
  5. c = 2*sqr(3)/9
  6. cc = sqr(12) / 6
  7.  
  8. sw = 1024
  9. sh = 768
  10.  
  11. screen _newimage(sw, sh, 12)
  12. tri sw/2, sh/2, 600, 0
  13. tri sw/2, sh/2, 600, pi
  14. koch sw/2, sh/2, 600, 3
  17.  
  18. sub koch(x, y, s, i)
  19.         if i = 0 then exit sub
  20.         for a = pi/6 to 2*pi + pi/6 step pi/3
  21.                 xx = s*c*cos(a) + x
  22.                 yy = s*c*sin(a) + y
  23.        
  24.                 tri xx, yy, s/3, a+pi/6
  25.                 tri xx, yy, s/3, a+pi/6+pi
  26.  
  27.                 koch xx, yy, s/3, i - 1
  28.         next
  30.  
  31. sub tri(x, y, s, a)
  32.         line(x,y)-(x+s*cc*cos(pi/6 + a),y+s*cc*sin(pi/6 + a)),8
  33.         line(x,y)-(x+s*cc*cos(5*pi/6 + a),y+s*cc*sin(5*pi/6 + a)),8
  34.         line(x,y)-(x-s*cc*cos(pi/2 + a),y-s*cc*sin(pi/2 + a)),8
  35.  
  36.         line(x+s*cc*cos(pi/6 + a),y+s*cc*sin(pi/6 + a))-(x+s*cc*cos(5*pi/6 + a),y+s*cc*sin(5*pi/6 + a))
  37.         line-(x-s*cc*cos(pi/2 + a),y-s*cc*sin(pi/2 + a))
  38.         line-(x+s*cc*cos(pi/6 + a),y+s*cc*sin(pi/6 + a))
  40.  
Title: Re: Fractals! : Part 2
Post by: Ashish on March 16, 2018, 08:18:47 am
@v
That was cool!
Title: Re: Fractals! : Part 2
Post by: bplus on March 16, 2018, 09:06:52 am
Yes, like the new Matrix Effect added to library, you get lot's of bang for your byte.

With recursive methods, it is amazing how much can be done with so few code lines.
Title: Re: Fractals! : Part 2
Post by: Ashish on March 16, 2018, 12:00:12 pm
Some more......

8. Bushes [Type 1]

Code: QB64: [Select]
  1. DEFDBL A-Z
  2. _TITLE "Bushes"
  3.  
  4. SCREEN _NEWIMAGE(800, 700, 32)
  5.  
  6. TYPE rule_type
  7.     token AS STRING * 1
  8.     replace AS STRING * 256
  10. TYPE __state
  11.     x AS DOUBLE
  12.     y AS DOUBLE
  13.     ang AS DOUBLE
  15.  
  16.  
  17. DIM  fractalData$
  18. DIM fractalRule(1) AS rule_type
  19. fractalRule(0).token = "F"
  20. fractalRule(0).replace = "FF"
  21. fractalRule(1).token = "X"
  22. fractalRule(1).replace = "F-[[X]+X]+F[+FX]-X"
  23. PRINT "Generating"
  24. fractalData$ = generateGrammer("X", fractalRule(), 8)
  25.  
  26. COLOR _RGBA(0, 255, 0, 45)
  27. drawFractal fractalData$, 22.5, 1, _WIDTH / 2, _HEIGHT, .5, 0, .5
  29.  
  30. SUB drawFractal (grammer$, ang, r, x, y, w, r_f, w_f)
  31.  
  32.     REDIM stat(1) AS __state
  33.     curr_state = 1
  34.     ang2 = 0
  35.     px = x
  36.     py = y
  37.     FOR i = 1 TO LEN(grammer$)
  38.         ca$ = MID$(grammer$, i, 1)
  39.         SELECT CASE ca$
  40.             CASE "F"
  41.                 xx = COS(_D2R(ang2 - 90)) * r + px
  42.                 yy = SIN(_D2R(ang2 - 90)) * r + py
  43.  
  44.                 LINE (px, py)-(xx, yy)
  45.                 'thickLine px, py, xx, yy, w
  46.                 px = xx
  47.                 py = yy
  48.             CASE "f"
  49.                 xx = COS(_D2R(ang2)) * r + px
  50.                 yy = SIN(_D2R(ang2)) * r + py
  51.                 px = xx
  52.                 py = yy
  53.             CASE "+"
  54.                 ang2 = ang2 + ang
  55.             CASE "-"
  56.                 ang2 = ang2 - ang
  57.             CASE "["
  58.                 stat(curr_state).x = px
  59.                 stat(curr_state).y = py
  60.                 stat(curr_state).ang = ang2
  61.                 curr_state = curr_state + 1
  62.                 REDIM _PRESERVE stat(curr_state) AS __state
  63.             CASE "]"
  64.                 curr_state = curr_state - 1
  65.                 px = stat(curr_state).x
  66.                 py = stat(curr_state).y
  67.                 ang2 = stat(curr_state).ang
  68.                 REDIM _PRESERVE stat(curr_state) AS __state
  69.             CASE "|"
  70.                 ang2 = ang2 + 180
  71.             CASE ">"
  72.                 r = r * r_f
  73.             CASE "<"
  74.                 r = r / r_f
  75.             CASE "#"
  76.                 w = w + w_f
  77.             CASE "!"
  78.                 w = w - w_f
  79.         END SELECT
  80.     NEXT
  82.  
  83. 'L-System Function
  84. FUNCTION generateGrammer$ (axiom$, rule() AS rule_type, n~&)
  85.     axiom2$ = axiom$
  86.     axiom3$ = ""
  87.     DO
  88.         FOR i = 1 TO LEN(axiom2$)
  89.             ca$ = MID$(axiom2$, i, 1)
  90.             nca$ = ca$
  91.             FOR j = 0 TO UBOUND(rule)
  92.                 IF rule(j).token = ca$ THEN
  93.                     nca$ = RTRIM$(rule(j).replace)
  94.                     EXIT FOR
  95.                 END IF
  96.             NEXT
  97.             axiom3$ = axiom3$ + nca$
  98.         NEXT
  99.         axiom2$ = axiom3$
  100.         axiom3$ = ""
  101.         count = count + 1
  102.         PRINT ".";
  103.     LOOP UNTIL count >= n~&
  104.     generateGrammer$ = axiom2$
  106.  
  107.  
  108.  
  109.  

9. Bushes [Type 2]

Code: QB64: [Select]
  1. DEFDBL A-Z
  2. _TITLE "Bushes [Type 2]"
  3.  
  4. SCREEN _NEWIMAGE(800, 700, 32)
  5.  
  6. TYPE rule_type
  7.     token AS STRING * 1
  8.     replace AS STRING * 256
  10. TYPE __state
  11.     x AS DOUBLE
  12.     y AS DOUBLE
  13.     ang AS DOUBLE
  15.  
  16.  
  17. DIM  fractalData$
  18. DIM fractalRule(1) AS rule_type
  19. fractalRule(0).token = "X"
  20. fractalRule(0).replace = "X[-FFF][+FFF]FX"
  21. fractalRule(1).token = "Y"
  22. fractalRule(1).replace = "YFX[+Y][-Y]"
  23. PRINT "Generating"
  24. fractalData$ = generateGrammer("Y", fractalRule(), 7)
  25.  
  26. COLOR _RGBA(255, 255, 255, 145)
  27. drawFractal fractalData$, 25.7, 2, _WIDTH / 2, _HEIGHT, .5, 0, .5
  29.  
  30. SUB drawFractal (grammer$, ang, r, x, y, w, r_f, w_f)
  31.  
  32.     REDIM stat(1) AS __state
  33.     curr_state = 1
  34.     ang2 = 0
  35.     px = x
  36.     py = y
  37.     FOR i = 1 TO LEN(grammer$)
  38.         ca$ = MID$(grammer$, i, 1)
  39.         SELECT CASE ca$
  40.             CASE "F"
  41.                 xx = COS(_D2R(ang2 - 90)) * r + px
  42.                 yy = SIN(_D2R(ang2 - 90)) * r + py
  43.  
  44.                 LINE (px, py)-(xx, yy)
  45.                 'thickLine px, py, xx, yy, w
  46.                 px = xx
  47.                 py = yy
  48.             CASE "f"
  49.                 xx = COS(_D2R(ang2)) * r + px
  50.                 yy = SIN(_D2R(ang2)) * r + py
  51.                 px = xx
  52.                 py = yy
  53.             CASE "+"
  54.                 ang2 = ang2 + ang
  55.             CASE "-"
  56.                 ang2 = ang2 - ang
  57.             CASE "["
  58.                 stat(curr_state).x = px
  59.                 stat(curr_state).y = py
  60.                 stat(curr_state).ang = ang2
  61.                 curr_state = curr_state + 1
  62.                 REDIM _PRESERVE stat(curr_state) AS __state
  63.             CASE "]"
  64.                 curr_state = curr_state - 1
  65.                 px = stat(curr_state).x
  66.                 py = stat(curr_state).y
  67.                 ang2 = stat(curr_state).ang
  68.                 REDIM _PRESERVE stat(curr_state) AS __state
  69.             CASE "|"
  70.                 ang2 = ang2 + 180
  71.             CASE ">"
  72.                 r = r * r_f
  73.             CASE "<"
  74.                 r = r / r_f
  75.             CASE "#"
  76.                 w = w + w_f
  77.             CASE "!"
  78.                 w = w - w_f
  79.         END SELECT
  80.     NEXT
  82.  
  83. 'L-System Function
  84. FUNCTION generateGrammer$ (axiom$, rule() AS rule_type, n~&)
  85.     axiom2$ = axiom$
  86.     axiom3$ = ""
  87.     DO
  88.         FOR i = 1 TO LEN(axiom2$)
  89.             ca$ = MID$(axiom2$, i, 1)
  90.             nca$ = ca$
  91.             FOR j = 0 TO UBOUND(rule)
  92.                 IF rule(j).token = ca$ THEN
  93.                     nca$ = RTRIM$(rule(j).replace)
  94.                     EXIT FOR
  95.                 END IF
  96.             NEXT
  97.             axiom3$ = axiom3$ + nca$
  98.         NEXT
  99.         axiom2$ = axiom3$
  100.         axiom3$ = ""
  101.         count = count + 1
  102.         PRINT ".";
  103.     LOOP UNTIL count >= n~&
  104.     generateGrammer$ = axiom2$
  106.  
  107.  
  108.  
  109.  

10. Bushes [Type 3]

Code: QB64: [Select]
  1. DEFDBL A-Z
  2. _TITLE "Bushes [Type 3]"
  3.  
  4. SCREEN _NEWIMAGE(800, 700, 32)
  5.  
  6. TYPE rule_type
  7.     token AS STRING * 1
  8.     replace AS STRING * 256
  10. TYPE __state
  11.     x AS DOUBLE
  12.     y AS DOUBLE
  13.     ang AS DOUBLE
  15.  
  16.  
  17. DIM  fractalData$
  18. DIM fractalRule(0) AS rule_type
  19.  
  20. fractalRule(0).token = "F"
  21. fractalRule(0).replace = "FF+[+F-F-F]-[-F+F+F]"
  22.  
  23. PRINT "Generating"
  24. fractalData$ = generateGrammer("F", fractalRule(), 6)
  25.  
  26. COLOR _RGBA(255, 255, 255, 40)
  27. drawFractal fractalData$, 22.5, 3, _WIDTH / 2, _HEIGHT, 0, 0, 0
  29.  
  30. SUB drawFractal (grammer$, ang, r, x, y, w, r_f, w_f)
  31.  
  32.     REDIM stat(1) AS __state
  33.     curr_state = 1
  34.     ang2 = 0
  35.     px = x
  36.     py = y
  37.     FOR i = 1 TO LEN(grammer$)
  38.         ca$ = MID$(grammer$, i, 1)
  39.         SELECT CASE ca$
  40.             CASE "F"
  41.                 xx = COS(_D2R(ang2 - 90)) * r + px
  42.                 yy = SIN(_D2R(ang2 - 90)) * r + py
  43.  
  44.                 LINE (px, py)-(xx, yy)
  45.                 'thickLine px, py, xx, yy, w
  46.                 px = xx
  47.                 py = yy
  48.             CASE "f"
  49.                 xx = COS(_D2R(ang2)) * r + px
  50.                 yy = SIN(_D2R(ang2)) * r + py
  51.                 px = xx
  52.                 py = yy
  53.             CASE "+"
  54.                 ang2 = ang2 + ang
  55.             CASE "-"
  56.                 ang2 = ang2 - ang
  57.             CASE "["
  58.                 stat(curr_state).x = px
  59.                 stat(curr_state).y = py
  60.                 stat(curr_state).ang = ang2
  61.                 curr_state = curr_state + 1
  62.                 REDIM _PRESERVE stat(curr_state) AS __state
  63.             CASE "]"
  64.                 curr_state = curr_state - 1
  65.                 px = stat(curr_state).x
  66.                 py = stat(curr_state).y
  67.                 ang2 = stat(curr_state).ang
  68.                 REDIM _PRESERVE stat(curr_state) AS __state
  69.             CASE "|"
  70.                 ang2 = ang2 + 180
  71.             CASE ">"
  72.                 r = r * r_f
  73.             CASE "<"
  74.                 r = r / r_f
  75.             CASE "#"
  76.                 w = w + w_f
  77.             CASE "!"
  78.                 w = w - w_f
  79.         END SELECT
  80.     NEXT
  82.  
  83. 'L-System Function
  84. FUNCTION generateGrammer$ (axiom$, rule() AS rule_type, n~&)
  85.     axiom2$ = axiom$
  86.     axiom3$ = ""
  87.     DO
  88.         FOR i = 1 TO LEN(axiom2$)
  89.             ca$ = MID$(axiom2$, i, 1)
  90.             nca$ = ca$
  91.             FOR j = 0 TO UBOUND(rule)
  92.                 IF rule(j).token = ca$ THEN
  93.                     nca$ = RTRIM$(rule(j).replace)
  94.                     EXIT FOR
  95.                 END IF
  96.             NEXT
  97.             axiom3$ = axiom3$ + nca$
  98.         NEXT
  99.         axiom2$ = axiom3$
  100.         axiom3$ = ""
  101.         count = count + 1
  102.         PRINT ".";
  103.     LOOP UNTIL count >= n~&
  104.     generateGrammer$ = axiom2$
  106.  
  107.  
  108.  
Title: Re: Fractals! : Part 2
Post by: bplus on August 07, 2020, 12:54:33 pm
@Ashish I don't know if I tried all these when you posted originally but Leaf #6 is currently not working.

Looking it over it seems all the arrays could be set once and for all instead of setting over and over in the recursive part of the app.
Title: Re: Fractals! : Part 2
Post by: Ashish on August 07, 2020, 01:01:32 pm
@bplus
Hm... It works for me.
Why is it not working for you is very surprising...

 
Title: Re: Fractals! : Part 2
Post by: Ashish on August 07, 2020, 01:11:48 pm
Try this one -
Code: QB64: [Select]
  1. 'Coded By Ashish in QB64
  2. _TITLE "Leaf"
  3. SCREEN _NEWIMAGE(800, 600, 32)
  4. DIM SHARED sx, sy, ox, oy, z
  6. ox = _WIDTH * .34
  7. oy = _HEIGHT
  8. z = 700
  9. COLOR _RGBA(0, 255, 0, 10)
  10. drawLeaf 0, 0, 0
  12.     p = sx: q = sy
  13.     drawLeaf p, q, 0
  14.     _LIMIT 30
  16.  
  17. SUB drawLeaf (x!, y!, N AS _UNSIGNED LONG)
  18.     STATIC a(3) AS SINGLE, b(3) AS SINGLE, c(3) AS SINGLE, d(3) AS SINGLE, e(3) AS SINGLE, f(3) AS SINGLE
  19.     IF N = 0 THEN
  20.         a(0) = 0: a(1) = .7248: a(2) = .1583: a = (3) = .3386
  21.         b(0) = .2439: b(1) = .0337: b(2) = -.1297: b(3) = .3694
  22.         c(0) = 0: c(1) = -.0253: c(2) = .355: c(3) = .2227
  23.         d(0) = .3053: d(1) = .7426: d(2) = .3676: d(3) = -.0756
  24.         e(0) = 0: e(1) = .206: e(2) = .1383: e(3) = .0679
  25.         f(0) = 0: f(1) = .2538: f(2) = .175: f(3) = .0826
  26.     END IF
  27.     k = INT(RND * 4)
  28.     xx! = a(k) * x! + b(k) * y! + e(k)
  29.     yy! = c(k) * x! + d(k) * y! + f(k)
  30.     PSET (xx! * z + ox, -yy! * z + oy)
  31.  
  32.     IF N < 10000 THEN
  33.         drawLeaf xx!, yy!, N + 1
  34.     ELSE sx = xx!: sy = yy!
  35.     END IF
  37.  
  38.  
Title: Re: Fractals! : Part 2
Post by: bplus on August 07, 2020, 01:26:30 pm
Got it working with this, simplified version:
Code: QB64: [Select]
  1. 'Coded By Ashish in QB64  B+ start mod fix 2020-08-07
  2. 'ref   https://www.qb64.org/forum/index.php?topic=182.msg955#msg955
  3. _TITLE "Leaf"
  4. SCREEN _NEWIMAGE(800, 600, 32)
  5. _DELAY .25
  8.  
  9. ' >>>>>>>>>>> moved this section out of drawLeaf
  10. DIM SHARED a(3) AS SINGLE, b(3) AS SINGLE, c(3) AS SINGLE, d(3) AS SINGLE, e(3) AS SINGLE, f(3) AS SINGLE
  11. a(0) = 0: a(1) = .7248: a(2) = .1583: a = (3) = .3386
  12. b(0) = .2439: b(1) = .0337: b(2) = -.1297: b(3) = .3694
  13. c(0) = 0: c(1) = -.0253: c(2) = .355: c(3) = .2227
  14. d(0) = .3053: d(1) = .7426: d(2) = .3676: d(3) = -.0756
  15. e(0) = 0: e(1) = .206: e(2) = .1383: e(3) = .0679
  16. f(0) = 0: f(1) = .2538: f(2) = .175: f(3) = .0826
  17.  
  18.  
  19. DIM SHARED sx, sy, ox, oy, z
  20. ox = _WIDTH * .34
  21. oy = _HEIGHT
  22. z = 700
  23. COLOR _RGB32(0, 255, 0, 10) '<<< added 32 version RGB
  24.  
  26.     p = sx: q = sy
  27.     drawLeaf p, q
  28. LOOP UNTIL _KEYDOWN(27) ' from INKEY$ <> ""
  29.  
  30. SUB drawLeaf (x!, y!) ' changed N from _unsigned nope remove completely!
  31.     k = INT(RND * 4)
  32.     xx! = a(k) * x! + b(k) * y! + e(k)
  33.     yy! = c(k) * x! + d(k) * y! + f(k)
  34.     LINE (xx! * z + ox, -yy! * z + oy)-STEP(2, 0), , BF
  35.     sx = xx!: sy = yy!
  36.     '....................... removed recursive calls because you do that in main loop
  38.  
  39.  
  40.  
  41.  
Title: Re: Fractals! : Part 2
Post by: bplus on August 07, 2020, 01:28:17 pm
@Ashish yes, your 2nd version works!


BTW these are very nice, glad to be reminded of them again!
Title: Re: Fractals! : Part 2
Post by: SierraKen on August 11, 2020, 05:10:14 pm
Awesome, your second Leaf works on my computer now too Ashish, thank you! I just put everyone's fractals in one folder so I don't lose any of them. :) I am also backing up all my QB64 apps.
Title: Re: Fractals! : Part 2
Post by: Aurel on August 13, 2020, 04:18:14 pm
Ashish
your fractals are simply great !
Title: Re: Fractals! : Part 2
Post by: 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)
Title: Re: Fractals! : Part 2
Post by: bplus 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:
 
Text Only | Text with Attachments