Rose Patterns

[bplus]

An easy one, so I challenged myself to show a pattern only once.

Code: QB64: [Select]

1. _TITLE "Rose Patterns for unique K values" 'started 2019-04-19 after viewing Shiffman's quicky
2. ' coding Challenge #55
3. ' [youtube]https://www.youtube.com/watch?v=f5QBExMNB1I&list=PLRqwX-V7Uu6ZiZxtDDRCi6uhfTH4FilpH[/youtube]&index=72
4.  
5. ' OK now try this without showing a k value twice, eg 1/2 = 2/4 = 3/6 = 4/8... just show .5 once!
6.  
7. CONST xmax = 800
8. CONST ymax = 600
9. SCREEN _NEWIMAGE(xmax, ymax, 32)
10. _SCREENMOVE _MIDDLE
11.  
12. ' don't show k values already shown, store k values shown in shownK() with nextKI for new K value
13. REDIM SHARED shownK(1 TO 1000), nextKI
14. nextKI = 1
15.  
16. 'review of equations
17. n = 1
18. d = 2
19. k = n / d
20. xc = xmax / 2
21. yc = ymax / 2
22. multiplier = 200
23. WHILE d <= 25
24.     WHILE n <= d
25.         CLS
26.         k = n / d
27.         IF find(k) = 0 THEN
28.             shownK(nextKI) = k
29.             QSort 1, nextKI
30.             nextKI = nextKI + 1
31.             IF nextKI > UBOUND(shownK) THEN
32.                 REDIM _PRESERVE shownK(1 TO UBOUND(shownK) + 1000)
33.             END IF
34.             FOR theta = 0 TO _PI(2) * d STEP .01
35.                 'main equations, r, x, y updated with every new theta
36.                 r = COS(k * theta)
37.                 x = xc + multiplier * r * COS(theta)
38.                 y = yc + multiplier * r * SIN(theta)
39.                 IF theta > 0 THEN LINE (lastx, lasty)-(x, y)
40.                 lastx = x: lasty = y
41.             NEXT
42.             PRINT "n ="; n; "  d ="; d; "  n/d = K ="; k
43.             _DISPLAY
44.             _LIMIT 1
45.         END IF
46.         n = n + 1
47.     WEND
48.     n = 1
49.     d = d + 1
50.  
51.     'check the values being stored, OK looks good!
52.     'IF d = 9 THEN 'dump shownK to check all unique numbers
53.     '    CLS
54.     '    FOR i = 1 TO nextKI - 1
55.     '        PRINT i, shownK(i)
56.     '        IF i MOD 30 = 0 THEN
57.     '            INPUT "Peeking at shownK array,  press enter to cont...", wate$
58.     '            CLS
59.     '        END IF
60.     '    NEXT
61.     '    INPUT "OK finished peek of shownK array, press enter to cont...", wate$
62.     '    CLS
63.     'END IF
64. WEND
65.  
66. SUB QSort (Start, Finish) 'shownK needs to be shared array
67.     i = Start
68.     j = Finish
69.     m = shownK(INT((i + j) / 2))
70.     WHILE i <= j
71.         WHILE shownK(i) < m
72.             i = i + 1
73.         WEND
74.         WHILE shownK(j) > m
75.             j = j - 1
76.         WEND
77.         IF i <= j THEN
78.             l = shownK(i)
79.             shownK(i) = shownK(j)
80.             shownK(j) = l
81.             i = i + 1
82.             j = j - 1
83.         END IF
84.     WEND
85.     IF j > Start THEN QSort Start, j
86.     IF i < Finish THEN QSort i, Finish
87. END SUB
88.  
89. FUNCTION find (x)
90.     IF nextKI = 1 THEN EXIT FUNCTION
91.     low = 1: hi = nextKI - 1
92.     WHILE low <= hi
93.         test = (low + hi) \ 2
94.         IF shownK(test) = x THEN
95.             find = test: EXIT FUNCTION
96.         ELSE
97.             IF shownK(test) < x THEN low = test + 1 ELSE hi = test - 1
98.         END IF
99.     WEND
100. END FUNCTION
101.  
102.  

So how would one color these?

[Ashish]

Hi bplus!
Here's my one -

Code: QB64: [Select]

1. 1 SCREEN _NEWIMAGE(600, 600, 32)
2. 2 RANDOMIZE TIMER
3. 3 rr = RND * 300
4. 4 d% = RND * 10 + 2
5. 5 k = INT(RND * 10) / d%
6. 6 xx = RND * _WIDTH
7. 7 yy = RND * _HEIGHT
8. 8 COLOR _RGB(RND * 256, RND * 256, RND * 256)
9. 9 FOR i = 0 TO d% * 2 * _PI STEP .1
10.    10 r = COS(k * i) + rr
11.    11 LINE (r * COS(k * i) * COS(i) + xx, r * COS(k * i) * SIN(i) + yy)-(r * COS(k * (i + .1)) * COS(i + .1) + xx, r * COS(k * (i + .1)) * SIN(i + .1) + yy)
12. 12 NEXT
13. 13 LINE (0, 0)-(_WIDTH, _HEIGHT), _RGBA(0, 0, 0, 100), BF
14. 14 _DELAY .1
15. 15 GOTO 3
16.  

[bplus]

Hi Ashish,

Line numbers!? Ha! reminds me of the dream last night I had trying to figure out how to color these. :)

[bplus]

Now with Coloring:

Code: QB64: [Select]

1. _TITLE "Rose Patterns with Coloring 2" 'started 2019-04-20
2. ' coding Challenge #55
3. ' [youtube]https://www.youtube.com/watch?v=f5QBExMNB1I&list=PLRqwX-V7Uu6ZiZxtDDRCi6uhfTH4FilpH[/youtube]&index=72
4.  
5. ' OK now try this without showing a k value twice, eg 1/2 = 2/4 = 3/6 = 4/8... just show .5 once!
6. '2019-04-20 with Coloring, by thic lines, well yuck so far trying to taper line back to xc,yc yuck 2
7. ' try expanding / contracting  multiplier, hell no!
8. '2019-04-20 with Coloring 2, OK alpha coloring is working well.
9.  
10.  
11. CONST xmax = 800
12. CONST ymax = 600
13. SCREEN _NEWIMAGE(xmax, ymax, 32)
14. _SCREENMOVE _MIDDLE
15.  
16. ' don't show k values already shown, store k values shown in shownK() with nextKI for new K value
17. REDIM SHARED shownK(1 TO 1000), nextKI
18. nextKI = 1
19.  
20. 'review of equations
21. n = 1
22. d = 2
23. k = n / d
24. xc = xmax / 2
25. yc = ymax / 2
26. multiplier = 200
27. WHILE d <= 25
28.     WHILE n <= d
29.         CLS
30.         k = n / d
31.         IF find(k) = 0 THEN
32.             shownK(nextKI) = k
33.             QSort 1, nextKI
34.             nextKI = nextKI + 1
35.             IF nextKI > UBOUND(shownK) THEN
36.                 REDIM _PRESERVE shownK(1 TO UBOUND(shownK) + 1000)
37.             END IF
38.             cnt = 0: dir = 1
39.             FOR theta = 0 TO _PI(2) * d STEP .01
40.                 'main equations, r, x, y updated with every new theta
41.                 cnt = cnt + dir
42.                 IF cnt > 255 THEN cnt = 254: dir = -1
43.                 IF cnt < 0 THEN cnt = 1: dir = 1
44.                 r = COS(k * theta)
45.                 x = xc + multiplier * r * COS(theta)
46.                 y = yc + multiplier * r * SIN(theta)
47.                 thic2 xc, yc, x, y, 2, _RGBA32(185, 0, 50, 80)
48.             NEXT
49.             PRINT "n ="; n; "  d ="; d; "  n/d = K ="; k
50.             _DISPLAY
51.             _LIMIT 1
52.         END IF
53.  
54.         n = n + 1
55.     WEND
56.     n = 1
57.     d = d + 1
58.  
59.     'check the values being stored, OK looks good!
60.     'IF d = 9 THEN 'dump shownK to check all unique numbers
61.     '    CLS
62.     '    FOR i = 1 TO nextKI - 1
63.     '        PRINT i, shownK(i)
64.     '        IF i MOD 30 = 0 THEN
65.     '            INPUT "Peeking at shownK array,  press enter to cont...", wate$
66.     '            CLS
67.     '        END IF
68.     '    NEXT
69.     '    INPUT "OK finished peek of shownK array, press enter to cont...", wate$
70.     '    CLS
71.     'END IF
72. WEND
73.  
74. SUB QSort (Start, Finish) 'shownK needs to be shared array
75.     i = Start
76.     j = Finish
77.     m = shownK(INT((i + j) / 2))
78.     WHILE i <= j
79.         WHILE shownK(i) < m
80.             i = i + 1
81.         WEND
82.         WHILE shownK(j) > m
83.             j = j - 1
84.         WEND
85.         IF i <= j THEN
86.             l = shownK(i)
87.             shownK(i) = shownK(j)
88.             shownK(j) = l
89.             i = i + 1
90.             j = j - 1
91.         END IF
92.     WEND
93.     IF j > Start THEN QSort Start, j
94.     IF i < Finish THEN QSort i, Finish
95. END SUB
96.  
97. FUNCTION find (x)
98.     IF nextKI = 1 THEN EXIT FUNCTION
99.     low = 1: hi = nextKI - 1
100.     WHILE low <= hi
101.         test = (low + hi) \ 2
102.         IF shownK(test) = x THEN
103.             find = test: EXIT FUNCTION
104.         ELSE
105.             IF shownK(test) < x THEN low = test + 1 ELSE hi = test - 1
106.         END IF
107.     WEND
108. END FUNCTION
109.  
110. SUB thic2 (x1, y1, x2, y2, rThick, K AS _UNSIGNED LONG)
111.     'x1, y1 is one endpoint of line
112.     'x2, y2 is the other endpoint of the line
113.     'rThick is the radius of the tiny circles that will be drawn
114.     '   from one end point to the other to create the thick line
115.     'Yes, the line will then extend beyond the endpoints with circular ends.
116.     rThick = INT(rThick / 2): stepx = x2 - x1: stepy = y2 - y1
117.     length = INT((stepx ^ 2 + stepy ^ 2) ^ .5)
118.     IF length THEN
119.         dx = stepx / length: dy = stepy / length
120.         FOR i = 0 TO length
121.             IF i = length THEN
122.                 fcirc x1 + dx * i, y1 + dy * i, 2, K
123.             ELSE
124.                 fcirc x1 + dx * i, y1 + dy * i, rThick, _RGBA32(235, 0, 110, 18)
125.             END IF
126.         NEXT
127.     ELSE
128.         fcirc x1, y1, rThick, K
129.     END IF
130. END SUB
131.  
132. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
133.     DIM Radius AS INTEGER, RadiusError AS INTEGER
134.     DIM X AS INTEGER, Y AS INTEGER
135.  
136.     Radius = ABS(R)
137.     RadiusError = -Radius
138.     X = Radius
139.     Y = 0
140.  
141.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
142.  
143.     ' Draw the middle span here so we don't draw it twice in the main loop,
144.     ' which would be a problem with blending turned on.
145.     LINE (CX - X, CY)-(CX + X, CY), C, BF
146.  
147.     WHILE X > Y
148.         RadiusError = RadiusError + Y * 2 + 1
149.         IF RadiusError >= 0 THEN
150.             IF X <> Y + 1 THEN
151.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
152.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
153.             END IF
154.             X = X - 1
155.             RadiusError = RadiusError - X * 2
156.         END IF
157.         Y = Y + 1
158.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
159.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
160.     WEND
161. END SUB
162.  
163.  

[bplus]

One more slight mod:

Code: QB64: [Select]

1. _TITLE "Rose Patterns with Coloring 3" 'started 2019-04-20
2. ' coding Challenge #55
3. ' [youtube]https://www.youtube.com/watch?v=f5QBExMNB1I&list=PLRqwX-V7Uu6ZiZxtDDRCi6uhfTH4FilpH[/youtube]&index=72
4.  
5. ' OK now try this without showing a k value twice, eg 1/2 = 2/4 = 3/6 = 4/8... just show .5 once!
6. '2019-04-20 with Coloring, by thic lines, well yuck so far trying to taper line back to xc,yc yuck 2
7. ' try expanding / contracting  multiplier, hell no!
8. '2019-04-20 with Coloring 2, OK alpha coloring is working well.
9. '2019-04-20 with Coloring 3, how about some yellow in center?
10.  
11.  
12. CONST xmax = 800
13. CONST ymax = 600
14. SCREEN _NEWIMAGE(xmax, ymax, 32)
15. _SCREENMOVE _MIDDLE
16.  
17. ' don't show k values already shown, store k values shown in shownK() with nextKI for new K value
18. REDIM SHARED shownK(1 TO 1000), nextKI
19. nextKI = 1
20.  
21. 'review of equations
22. n = 1
23. d = 2
24. k = n / d
25. xc = xmax / 2
26. yc = ymax / 2
27. multiplier = 200
28. WHILE d <= 25
29.     WHILE n <= d
30.         CLS
31.         k = n / d
32.         IF find(k) = 0 THEN
33.             shownK(nextKI) = k
34.             QSort 1, nextKI
35.             nextKI = nextKI + 1
36.             IF nextKI > UBOUND(shownK) THEN
37.                 REDIM _PRESERVE shownK(1 TO UBOUND(shownK) + 1000)
38.             END IF
39.             cnt = 0: dir = 1
40.             FOR theta = 0 TO _PI(2) * d STEP .01
41.                 'main equations, r, x, y updated with every new theta
42.                 cnt = cnt + dir
43.                 IF cnt > 255 THEN cnt = 254: dir = -1
44.                 IF cnt < 0 THEN cnt = 1: dir = 1
45.                 r = COS(k * theta)
46.                 x = xc + multiplier * r * COS(theta)
47.                 y = yc + multiplier * r * SIN(theta)
48.                 thic2 xc, yc, x, y, 2, _RGBA32(185, 0, 50, 80)
49.             NEXT
50.             PRINT "n ="; n; "  d ="; d; "  n/d = K ="; k
51.             _DISPLAY
52.             _LIMIT 1
53.         END IF
54.  
55.         n = n + 1
56.     WEND
57.     n = 1
58.     d = d + 1
59.  
60.     'check the values being stored, OK looks good!
61.     'IF d = 9 THEN 'dump shownK to check all unique numbers
62.     '    CLS
63.     '    FOR i = 1 TO nextKI - 1
64.     '        PRINT i, shownK(i)
65.     '        IF i MOD 30 = 0 THEN
66.     '            INPUT "Peeking at shownK array,  press enter to cont...", wate$
67.     '            CLS
68.     '        END IF
69.     '    NEXT
70.     '    INPUT "OK finished peek of shownK array, press enter to cont...", wate$
71.     '    CLS
72.     'END IF
73. WEND
74.  
75. SUB QSort (Start, Finish) 'shownK needs to be shared array
76.     i = Start
77.     j = Finish
78.     m = shownK(INT((i + j) / 2))
79.     WHILE i <= j
80.         WHILE shownK(i) < m
81.             i = i + 1
82.         WEND
83.         WHILE shownK(j) > m
84.             j = j - 1
85.         WEND
86.         IF i <= j THEN
87.             l = shownK(i)
88.             shownK(i) = shownK(j)
89.             shownK(j) = l
90.             i = i + 1
91.             j = j - 1
92.         END IF
93.     WEND
94.     IF j > Start THEN QSort Start, j
95.     IF i < Finish THEN QSort i, Finish
96. END SUB
97.  
98. FUNCTION find (x)
99.     IF nextKI = 1 THEN EXIT FUNCTION
100.     low = 1: hi = nextKI - 1
101.     WHILE low <= hi
102.         test = (low + hi) \ 2
103.         IF shownK(test) = x THEN
104.             find = test: EXIT FUNCTION
105.         ELSE
106.             IF shownK(test) < x THEN low = test + 1 ELSE hi = test - 1
107.         END IF
108.     WEND
109. END FUNCTION
110.  
111. SUB thic2 (x1, y1, x2, y2, rThick, K AS _UNSIGNED LONG)
112.     'x1, y1 is one endpoint of line
113.     'x2, y2 is the other endpoint of the line
114.     'rThick is the radius of the tiny circles that will be drawn
115.     '   from one end point to the other to create the thick line
116.     'Yes, the line will then extend beyond the endpoints with circular ends.
117.     rThick = INT(rThick / 2): stepx = x2 - x1: stepy = y2 - y1
118.     length = INT((stepx ^ 2 + stepy ^ 2) ^ .5)
119.     IF length THEN
120.         dx = stepx / length: dy = stepy / length
121.         FOR i = 0 TO length
122.             IF i = length THEN
123.                 fcirc x1 + dx * i, y1 + dy * i, 2, K
124.             ELSEIF i <= .4 * length THEN
125.                 fcirc x1 + dx * i, y1 + dy * i, rThick, _RGBA32(255, 255, 0, 3)
126.             ELSE
127.                 fcirc x1 + dx * i, y1 + dy * i, rThick, _RGBA32(235, 0, 110, 18)
128.             END IF
129.         NEXT
130.     ELSE
131.         fcirc x1, y1, rThick, K
132.     END IF
133. END SUB
134.  
135. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
136.     DIM Radius AS INTEGER, RadiusError AS INTEGER
137.     DIM X AS INTEGER, Y AS INTEGER
138.  
139.     Radius = ABS(R)
140.     RadiusError = -Radius
141.     X = Radius
142.     Y = 0
143.  
144.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
145.  
146.     ' Draw the middle span here so we don't draw it twice in the main loop,
147.     ' which would be a problem with blending turned on.
148.     LINE (CX - X, CY)-(CX + X, CY), C, BF
149.  
150.     WHILE X > Y
151.         RadiusError = RadiusError + Y * 2 + 1
152.         IF RadiusError >= 0 THEN
153.             IF X <> Y + 1 THEN
154.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
155.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
156.             END IF
157.             X = X - 1
158.             RadiusError = RadiusError - X * 2
159.         END IF
160.         Y = Y + 1
161.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
162.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
163.     WEND
164. END SUB
165.  
166.  

Sometimes it works:
 

[TempodiBasic]

Hi Bplus
Hi Ashish
yes math is beautiful!

[SierraKen]

Awesome flowers bplus! Sometimes I wonder what people have made for the years that I didn't know about QB64.