Fractals! : Part 2

[Ashish]

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
10. END TYPE
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.  
31. DO
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
99. LOOP
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)
108. END FUNCTION
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
118. END FUNCTION
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
130. END SUB
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
158. END SUB
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$
182. END FUNCTION
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
13. NEXT
14.  
15. SUB drawChristmasTree (x!, y!, N AS _UNSIGNED LONG)
16.     SELECT CASE RND
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
32. END SUB
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
14. NEXT
15. SUB drawDragon (x!, y!, N AS _UNSIGNED LONG)
16.     SELECT CASE RND
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
29. END SUB
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.  
6. RANDOMIZE TIMER
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
15. NEXT
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
37. END SUB
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
14. NEXT
15. sleep
16. SUB drawOldTree (x!, y!, N AS _UNSIGNED LONG)
17.     SELECT CASE RND
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
40. END SUB
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
5. RANDOMIZE TIMER
6. ox = _WIDTH * .34
7. oy = _HEIGHT
8. z = 700
9. COLOR _RGBA(0, 255, 0, 10)
10. drawLeaf 0, 0, 0
11. DO
12.     p = sx: q = sy
13.     drawLeaf p, q, 0
14.     _LIMIT 30
15. LOOP UNTIL INKEY$ <> ""
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
34. END SUB
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
14. NEXT
15. SLEEP
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
31. END SUB
32.  
33.  

[bplus]

Very nice set of fractals!

[Ashish]

Very nice set of fractals!

Thanks bplus! :)

[_vince]

Nice use of recursion, very suitable to the nature of fractals.  Here's a program I found of a similar style

Code: QB64: [Select]

1. dim shared pi
2. dim shared c
3. dim shared cc
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
15. sleep
16. system
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
29. end sub
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))
39. end sub
40.  

[Ashish]

@v
That was cool!

[bplus]

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.

[Ashish]

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
9. END TYPE
10. TYPE __state
11.     x AS DOUBLE
12.     y AS DOUBLE
13.     ang AS DOUBLE
14. END TYPE
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
28. SLEEP
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
81. END SUB
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$
105. END FUNCTION
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
9. END TYPE
10. TYPE __state
11.     x AS DOUBLE
12.     y AS DOUBLE
13.     ang AS DOUBLE
14. END TYPE
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
28. SLEEP
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
81. END SUB
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$
105. END FUNCTION
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
9. END TYPE
10. TYPE __state
11.     x AS DOUBLE
12.     y AS DOUBLE
13.     ang AS DOUBLE
14. END TYPE
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
28. SLEEP
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
81. END SUB
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$
105. END FUNCTION
106.  
107.  
108.  

[bplus]

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

[Ashish]

@bplus
Hm... It works for me.
Why is it not working for you is very surprising...

 

[Ashish]

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
5. RANDOMIZE TIMER
6. ox = _WIDTH * .34
7. oy = _HEIGHT
8. z = 700
9. COLOR _RGBA(0, 255, 0, 10)
10. drawLeaf 0, 0, 0
11. DO
12.     p = sx: q = sy
13.     drawLeaf p, q, 0
14.     _LIMIT 30
15. LOOP UNTIL INKEY$ <> ""
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
36. END SUB
37.  
38.  

[bplus]

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
6. _SCREENMOVE _MIDDLE
7. RANDOMIZE TIMER
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.  
25. DO
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
37. END SUB
38.  
39.  
40.  
41.  

[bplus]

@Ashish yes, your 2nd version works!


BTW these are very nice, glad to be reminded of them again!

[SierraKen]

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.

[Aurel]

Ashish
your fractals are simply great !

[Bolee]

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)