Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: bplus on April 19, 2019, 11:54:57 pm

Title: Rose Patterns
Post by: bplus on April 19, 2019, 11:54:57 pm
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)
  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
  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
  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
  101.  
  102.  

So how would one color these?
Title: Re: Rose Patterns
Post by: Ashish on April 20, 2019, 12:29:30 am
Hi bplus!
Here's my one -
Code: QB64: [Select]
  1. 1 SCREEN _NEWIMAGE(600, 600, 32)
  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.  
Title: Re: Rose Patterns
Post by: bplus on April 20, 2019, 09:30:59 am
Hi Ashish,

Line numbers!? Ha! reminds me of the dream last night I had trying to figure out how to color these. :)
Title: Re: Rose Patterns
Post by: bplus on April 20, 2019, 12:07:14 pm
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)
  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
  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
  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
  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
  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
  162.  
  163.  
Title: Re: Rose Patterns
Post by: bplus on April 20, 2019, 12:55:23 pm
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)
  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
  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
  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
  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
  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
  165.  
  166.  

Sometimes it works:
  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Title: Re: Rose Patterns
Post by: TempodiBasic on April 20, 2019, 05:52:06 pm
Hi Bplus
Hi Ashish
yes math is beautiful!
Title: Re: Rose Patterns
Post by: SierraKen on October 29, 2019, 12:37:58 pm
Awesome flowers bplus! Sometimes I wonder what people have made for the years that I didn't know about QB64.
Text Only | Text with Attachments