Text Only | Text with Attachments

QB64.org Forum

Active Forums => Programs => Topic started by: bplus on January 27, 2019, 10:23:28 pm

Title: Morph Curve
Post by: bplus on January 27, 2019, 10:23:28 pm
That Paul Dunn does some cool stuff!
Code: QB64: [Select]
  1. _TITLE "Morph Curve" 'for QB64 B+ 2019-01-27
  2. ' Morph Curve.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-04-11
  3. 'from SpecBAS version Paul Dunn Dec 2, 2015
  4. '[youtube]https://www.youtube.com/watch?v=j2rmBRLEVms[/youtube]
  5.  
  6. 'prep
  7. CONST xmax = 700
  8. CONST ymax = 700
  9. SCREEN _NEWIMAGE(xmax, ymax, 32)
  10. _SCREENMOVE 100, 20
  11. pts = 12000: interps = 20
  12. REDIM p(pts + 1, 1), q(pts + 1, 1), s(pts + 1, 1), i(interps)
  13. l = 0: cx = xmax / 2: cy = ymax / 2: sc = cy * .5: st = 2 * _PI / pts
  14. FOR n = 1 TO interps
  15.     i(n) = SIN(n / interps * (_PI / 2))
  17.  
  18. 'main
  19. n = 0: m = 0: rmode = 0
  21.     c = 0
  22.     IF INKEY$ = " " THEN rmode = 1
  23.     IF rmode = 0 THEN
  24.         n = n + 1
  25.         IF n > 12 THEN n = 0: m = m + 1
  26.         IF m > 12 THEN rmode = 1
  27.     END IF
  28.     IF rmode THEN n = rand(1, 75): m = rand(-250, 250)
  29.     FOR t = 0 TO 2 * _PI STEP st
  30.  
  31.         q(c, 0) = cx + sc * (COS(t) + COS(n * t) / 2 + SIN(m * t) / 3)
  32.         q(c, 1) = cy + sc * (SIN(t) + SIN(n * t) / 2 + COS(m * t) / 3)
  33.         c = c + 1
  34.     NEXT
  35.     q(c, 0) = q(0, 0): q(c, 1) = q(0, 1)
  36.     CLS
  37.     PRINT "m = "; m; "  n = "; n; "  spacebar skips to random mode."
  38.     IF l = 0 THEN
  39.         drawpoly q()
  40.         l = l + 1
  41.         _DISPLAY
  42.         _DELAY 10 / 1000
  43.     ELSE
  44.         FOR t = 1 TO interps
  45.             CLS
  46.             PRINT "m = "; m; "  n = "; n;
  47.             IF rmode <> 1 THEN PRINT "  spacebar skips to random mode." ELSE PRINT
  48.             FOR nn = 0 TO pts
  49.                 s(nn, 0) = q(nn, 0) * i(t) + p(nn, 0) * (1 - i(t))
  50.                 s(nn, 1) = q(nn, 1) * i(t) + p(nn, 1) * (1 - i(t))
  51.             NEXT
  52.             s(nn, 0) = s(0, 0)
  53.             s(nn, 1) = s(0, 1)
  54.             drawpoly s()
  55.             _DISPLAY
  56.             _DELAY 10 / 1000
  57.         NEXT
  58.     END IF
  59.     _DISPLAY
  60.     _DELAY 100 / 1000
  61.     'p() = q()
  62.     REDIM p(LBOUND(q) TO UBOUND(q), 1)
  63.     FOR i = LBOUND(q) TO UBOUND(q)
  64.         p(i, 0) = q(i, 0): p(i, 1) = q(i, 1)
  65.     NEXT
  67.  
  68. FUNCTION rand (lo, hi)
  69.     rand = (RND * (hi - lo + 1)) \ 1 + lo
  71.  
  72. SUB drawpoly (a())
  73.     FOR i = LBOUND(a) TO UBOUND(a) - 1
  74.         LINE (a(i, 0), a(i, 1))-(a(i + 1, 0), a(i + 1, 1))
  75.     NEXT
  76.     LINE (a(UBOUND(a), 0), a(UBOUND(a), 1))-(a(LBOUND(a), 0), a(LBOUND(a), 1))
  78.  
Title: Re: Morph Curve
Post by: Petr on January 28, 2019, 01:31:22 am
Hell, that's really good!
Title: Re: Morph Curve
Post by: johnno56 on January 28, 2019, 05:29:55 pm
Cool... Reminds me of a bowl of spaghetti... Mmm... Pasta.
Title: Re: Morph Curve
Post by: bplus on January 28, 2019, 05:33:07 pm
Thicker pasta and colorized pasta sauce (Hi Johnno!):
Code: QB64: [Select]
  1. _TITLE "Morph Curve Colorized" 'for QB64 B+ 2019-01-28
  2. ' Morph Curve.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-04-11
  3. 'from SpecBAS version Paul Dunn Dec 2, 2015
  4. '[youtube]https://www.youtube.com/watch?v=j2rmBRLEVms[/youtube]
  5.  
  6. 'prep
  7. CONST xmax = 700
  8. CONST ymax = 700
  9. SCREEN _NEWIMAGE(xmax, ymax, 32)
  10. _SCREENMOVE 100, 20
  11. DIM SHARED plasmaN, plasmaR, plasmaG, plasmaB
  12. pts = 12000: interps = 20
  13. REDIM p(pts + 1, 1), q(pts + 1, 1), s(pts + 1, 1), i(interps)
  14. l = 0: cx = xmax / 2: cy = ymax / 2: sc = cy * .5: st = 2 * _PI / pts
  15. FOR n = 1 TO interps
  16.     i(n) = SIN(n / interps * (_PI / 2))
  18.  
  19. 'main
  20. n = 0: m = 0: rmode = 0
  22.     resetPlasma
  23.     c = 0
  24.     IF INKEY$ = " " THEN rmode = 1
  25.     IF rmode = 0 THEN
  26.         n = n + 1
  27.         IF n > 12 THEN n = 0: m = m + 1
  28.         IF m > 12 THEN rmode = 1
  29.     END IF
  30.     IF rmode THEN n = rand(1, 75): m = rand(-250, 250)
  31.     FOR t = 0 TO 2 * _PI STEP st
  32.         q(c, 0) = cx + sc * (COS(t) + COS(n * t) / 2 + SIN(m * t) / 3)
  33.         q(c, 1) = cy + sc * (SIN(t) + SIN(n * t) / 2 + COS(m * t) / 3)
  34.         c = c + 1
  35.     NEXT
  36.     q(c, 0) = q(0, 0): q(c, 1) = q(0, 1)
  37.     CLS
  38.     PRINT "m = "; m; "  n = "; n; "  spacebar skips to random mode."
  39.     IF l = 0 THEN
  40.         drawpoly q()
  41.         l = l + 1
  42.         _DISPLAY
  43.         _DELAY 10 / 1000
  44.     ELSE
  45.         FOR t = 1 TO interps
  46.             CLS
  47.             PRINT "m = "; m; "  n = "; n;
  48.             IF rmode <> 1 THEN PRINT "  spacebar skips to random mode." ELSE PRINT
  49.             FOR nn = 0 TO pts
  50.                 s(nn, 0) = q(nn, 0) * i(t) + p(nn, 0) * (1 - i(t))
  51.                 s(nn, 1) = q(nn, 1) * i(t) + p(nn, 1) * (1 - i(t))
  52.             NEXT
  53.             s(nn, 0) = s(0, 0)
  54.             s(nn, 1) = s(0, 1)
  55.             drawpoly s()
  56.             _DISPLAY
  57.             _DELAY 10 / 1000
  58.         NEXT
  59.     END IF
  60.     _DISPLAY
  61.     _DELAY 100 / 1000
  62.     'p() = q()
  63.     REDIM p(LBOUND(q) TO UBOUND(q), 1)
  64.     FOR i = LBOUND(q) TO UBOUND(q)
  65.         p(i, 0) = q(i, 0): p(i, 1) = q(i, 1)
  66.     NEXT
  68.  
  69. FUNCTION rand (lo, hi)
  70.     rand = (RND * (hi - lo + 1)) \ 1 + lo
  72.  
  73. SUB drawpoly (a())
  74.     FOR i = LBOUND(a) TO UBOUND(a) - 1
  75.         kl~& = setPlasma~&
  76.         thic a(i, 0), a(i, 1), a(i + 1, 0), a(i + 1, 1), 4, kl~&
  77.     NEXT
  78.     kl~& = setPlasma~&
  79.     thic a(UBOUND(a), 0), a(UBOUND(a), 1), a(LBOUND(a), 0), a(LBOUND(a), 1), 4, kl~&
  81.  
  82. SUB thic (x1, y1, x2, y2, thick, K AS _UNSIGNED LONG)
  83.     'add filled circles at each end
  84.     t2 = thick / 2
  85.     IF t2 < 1 THEN t2 = 1
  86.     fcirc x1, y1, t2, K
  87.     fcirc x2, y2, t2, K
  88.     a = _ATAN2(y2 - y1, x2 - x1)
  89.     x3 = x1 + t2 * COS(a + _PI(.5))
  90.     y3 = y1 + t2 * SIN(a + _PI(.5))
  91.     x4 = x1 + t2 * COS(a - _PI(.5))
  92.     y4 = y1 + t2 * SIN(a - _PI(.5))
  93.     x5 = x2 + t2 * COS(a + _PI(.5))
  94.     y5 = y2 + t2 * SIN(a + _PI(.5))
  95.     x6 = x2 + t2 * COS(a - _PI(.5))
  96.     y6 = y2 + t2 * SIN(a - _PI(.5))
  97.     filltri x6, y6, x4, y4, x3, y3, K
  98.     filltri x3, y3, x5, y5, x6, y6, K
  100.  
  101. ' found at [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]:    http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=14425.0
  102. SUB filltri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
  103.     a& = _NEWIMAGE(1, 1, 32)
  104.     _DEST a&
  105.     PSET (0, 0), K
  106.     _DEST 0
  107.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
  108.     _FREEIMAGE a& '<<< this is important!
  110.  
  111. SUB resetPlasma () 'all globals
  112.     plasmaR = RND ^ 2: plasmaG = RND ^ 2: plasmaB = RND ^ 2: plasmaN = 0
  114.  
  115. FUNCTION setPlasma~& () 'all globals
  116.     plasmaN = plasmaN + .01
  117.     setPlasma~& = _RGB32(120 + 84 * SIN(plasmaR * plasmaN), 120 + 84 * SIN(plasmaG * plasmaN), 120 + 84 * SIN(plasmaB * plasmaN))
  119.  
  120. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
  121. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, K AS _UNSIGNED LONG)
  122.     DIM subRadius AS LONG, RadiusError AS LONG
  123.     DIM X AS LONG, Y AS LONG
  124.  
  125.     subRadius = ABS(R)
  126.     RadiusError = -subRadius
  127.     X = subRadius
  128.     Y = 0
  129.  
  130.     IF subRadius = 0 THEN PSET (CX, CY), K: EXIT SUB
  131.  
  132.     ' Draw the middle span here so we don't draw it twice in the main loop,
  133.     ' which would be a problem with blending turned on.
  134.     LINE (CX - X, CY)-(CX + X, CY), K, BF
  135.  
  136.     WHILE X > Y
  137.         RadiusError = RadiusError + Y * 2 + 1
  138.         IF RadiusError >= 0 THEN
  139.             IF X <> Y + 1 THEN
  140.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), K, BF
  141.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), K, BF
  142.             END IF
  143.             X = X - 1
  144.             RadiusError = RadiusError - X * 2
  145.         END IF
  146.         Y = Y + 1
  147.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), K, BF
  148.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), K, BF
  149.     WEND
  151.  
  152.  

EDIT: adjust thic call to 4 (from 3), as some lines were beady, need even thickness.
Title: Re: Morph Curve
Post by: johnno56 on January 29, 2019, 03:54:23 am
Much better! Linguini !!
Title: Re: Morph Curve
Post by: Pete on January 29, 2019, 10:32:28 am
Now Mark just needs to add balls... Meat balls!

Pete :D
Title: Re: Morph Curve
Post by: bplus on January 29, 2019, 11:29:16 am
Quote from: Pete on January 29, 2019, 10:32:28 am
Now Mark just needs to add balls... Meat balls!

Pete :D

Dang! why didn't I think of that? hmm...

Thanks Pete :D
Title: Re: Morph Curve
Post by: Pete on January 29, 2019, 12:42:28 pm
Don't worry about the pasta. I'll keep "stirring the pot" while you bang out your meatballs.

Pete :D
Title: Re: Morph Curve
Post by: bplus on January 29, 2019, 12:44:42 pm
OK I have added meatballs to the plate. They are red unless you look at them. ;-))
Code: QB64: [Select]
  1. _TITLE "Morph Curve Colorized and Balled" 'for QB64 B+ 2019-01-29
  2. ' Morph Curve.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-04-11
  3. 'from SpecBAS version Paul Dunn Dec 2, 2015
  4. '[youtube]https://www.youtube.com/watch?v=j2rmBRLEVms[/youtube]
  5.  
  6. '2019-01-29 add magic red meat balls to the plate
  7.  
  8. 'prep
  9. CONST xmax = 700
  10. CONST ymax = 700
  11. SCREEN _NEWIMAGE(xmax, ymax, 32)
  12. _SCREENMOVE 300, 20
  13. DIM SHARED plasmaN, plasmaR, plasmaG, plasmaB
  14. pts = 12000: interps = 20
  15. REDIM p(pts + 1, 1), q(pts + 1, 1), s(pts + 1, 1), i(interps)
  16. l = 0: cx = xmax / 2: cy = ymax / 2: sc = cy * .5: st = 2 * _PI / pts
  17. FOR n = 1 TO interps
  18.     i(n) = SIN(n / interps * (_PI / 2))
  20.  
  21. 'main
  22. n = 0: m = 0: rmode = 0
  24.     resetPlasma
  25.     c = 0
  26.     IF INKEY$ = " " THEN rmode = 1
  27.     IF rmode = 0 THEN
  28.         n = n + 1
  29.         IF n > 12 THEN n = 0: m = m + 1
  30.         IF m > 12 THEN rmode = 1
  31.     END IF
  32.     IF rmode THEN n = rand(1, 75): m = rand(-250, 250)
  33.     FOR t = 0 TO 2 * _PI STEP st
  34.         q(c, 0) = cx + sc * (COS(t) + COS(n * t) / 2 + SIN(m * t) / 3)
  35.         q(c, 1) = cy + sc * (SIN(t) + SIN(n * t) / 2 + COS(m * t) / 3)
  36.         c = c + 1
  37.     NEXT
  38.     q(c, 0) = q(0, 0): q(c, 1) = q(0, 1)
  39.     magicRedBalls
  40.     IF rmode <> 1 THEN
  41.         _TITLE "Morph Curve: m =" + STR$(m) + ",  n =" + STR$(n) + ",  spacebar skips to random mode."
  42.     ELSE
  43.         _TITLE "Morph Curve: m =" + STR$(m) + ",  n =" + STR$(n)
  44.     END IF
  45.     IF l = 0 THEN
  46.         drawpoly q()
  47.         l = l + 1
  48.         _DISPLAY
  49.         _DELAY 10 / 1000
  50.     ELSE
  51.         FOR t = 1 TO interps
  52.             magicRedBalls
  53.             FOR nn = 0 TO pts
  54.                 s(nn, 0) = q(nn, 0) * i(t) + p(nn, 0) * (1 - i(t))
  55.                 s(nn, 1) = q(nn, 1) * i(t) + p(nn, 1) * (1 - i(t))
  56.             NEXT
  57.             s(nn, 0) = s(0, 0)
  58.             s(nn, 1) = s(0, 1)
  59.             drawpoly s()
  60.             _DISPLAY
  61.             _DELAY 10 / 1000
  62.         NEXT
  63.     END IF
  64.     _DISPLAY
  65.     _DELAY 200 / 1000
  66.     'p() = q()
  67.     REDIM p(LBOUND(q) TO UBOUND(q), 1)
  68.     FOR i = LBOUND(q) TO UBOUND(q)
  69.         p(i, 0) = q(i, 0): p(i, 1) = q(i, 1)
  70.     NEXT
  72.  
  73. FUNCTION rand (lo, hi)
  74.     rand = (RND * (hi - lo + 1)) \ 1 + lo
  76.  
  77. SUB drawpoly (a())
  78.     FOR i = LBOUND(a) TO UBOUND(a) - 1
  79.         kl~& = setPlasma~&
  80.         thic a(i, 0), a(i, 1), a(i + 1, 0), a(i + 1, 1), 4, kl~&
  81.     NEXT
  82.     kl~& = setPlasma~&
  83.     thic a(UBOUND(a), 0), a(UBOUND(a), 1), a(LBOUND(a), 0), a(LBOUND(a), 1), 4, kl~&
  85.  
  86. SUB thic (x1, y1, x2, y2, thick, K AS _UNSIGNED LONG)
  87.     'add filled circles at each end
  88.     t2 = thick / 2
  89.     IF t2 < 1 THEN t2 = 1
  90.     fcirc x1, y1, t2, K
  91.     fcirc x2, y2, t2, K
  92.     a = _ATAN2(y2 - y1, x2 - x1)
  93.     x3 = x1 + t2 * COS(a + _PI(.5))
  94.     y3 = y1 + t2 * SIN(a + _PI(.5))
  95.     x4 = x1 + t2 * COS(a - _PI(.5))
  96.     y4 = y1 + t2 * SIN(a - _PI(.5))
  97.     x5 = x2 + t2 * COS(a + _PI(.5))
  98.     y5 = y2 + t2 * SIN(a + _PI(.5))
  99.     x6 = x2 + t2 * COS(a - _PI(.5))
  100.     y6 = y2 + t2 * SIN(a - _PI(.5))
  101.     filltri x6, y6, x4, y4, x3, y3, K
  102.     filltri x3, y3, x5, y5, x6, y6, K
  104.  
  105. ' found at [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]:    http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=14425.0
  106. SUB filltri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
  107.     a& = _NEWIMAGE(1, 1, 32)
  108.     _DEST a&
  109.     PSET (0, 0), K
  110.     _DEST 0
  111.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
  112.     _FREEIMAGE a& '<<< this is important!
  114.  
  115. SUB resetPlasma () 'all globals
  116.     plasmaR = RND ^ 2: plasmaG = RND ^ 2: plasmaB = RND ^ 2: plasmaN = 0
  118.  
  119. FUNCTION setPlasma~& () 'all globals
  120.     plasmaN = plasmaN + .01
  121.     setPlasma~& = _RGB32(120 + 84 * SIN(plasmaR * plasmaN), 120 + 84 * SIN(plasmaG * plasmaN), 120 + 84 * SIN(plasmaB * plasmaN))
  123.  
  124. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
  125. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, K AS _UNSIGNED LONG)
  126.     DIM subRadius AS LONG, RadiusError AS LONG
  127.     DIM X AS LONG, Y AS LONG
  128.  
  129.     subRadius = ABS(R)
  130.     RadiusError = -subRadius
  131.     X = subRadius
  132.     Y = 0
  133.  
  134.     IF subRadius = 0 THEN PSET (CX, CY), K: EXIT SUB
  135.  
  136.     ' Draw the middle span here so we don't draw it twice in the main loop,
  137.     ' which would be a problem with blending turned on.
  138.     LINE (CX - X, CY)-(CX + X, CY), K, BF
  139.  
  140.     WHILE X > Y
  141.         RadiusError = RadiusError + Y * 2 + 1
  142.         IF RadiusError >= 0 THEN
  143.             IF X <> Y + 1 THEN
  144.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), K, BF
  145.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), K, BF
  146.             END IF
  147.             X = X - 1
  148.             RadiusError = RadiusError - X * 2
  149.         END IF
  150.         Y = Y + 1
  151.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), K, BF
  152.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), K, BF
  153.     WEND
  155.  
  156. SUB magicRedBalls
  157.     COLOR _RGBA32(128, 128, 128, 100), _RGB32(120, 0, 0)
  158.     CLS
  159.     FOR i = 25 TO xmax STEP 50
  160.         LINE (i, 0)-(i + 10, ymax), , BF
  161.         LINE (0, i)-(xmax, i + 10), , BF
  162.     NEXT
  163.     COLOR
  164.     FOR y = 30 TO ymax STEP 50
  165.         FOR x = 30 TO xmax STEP 50
  166.             fcirc x, y, 10, _RGB32(128, 128, 128)
  167.         NEXT
  168.     NEXT
  169.     CIRCLE (xmax / 2, ymax / 2), 330, _RGB32(199, 199, 199)
  170.     CIRCLE (xmax / 2, ymax / 2), 410, _RGB32(199, 199, 199)
  171.     PAINT (xmax / 2, 5), _RGB32(180, 200, 180), _RGB32(199, 199, 199)
  172.     PAINT (10, 10), _RGB32(0, 68, 0), _RGB32(199, 199, 199)
  173.     PAINT (xmax - 10, 10), _RGB32(0, 68, 0), _RGB32(199, 199, 199)
  174.     PAINT (10, ymax - 10), _RGB32(0, 68, 0), _RGB32(199, 199, 199)
  175.     PAINT (xmax - 10, ymax - 10), _RGB32(0, 68, 0), _RGB32(199, 199, 199)
  176.     FOR r = 0 TO 20
  177.         CIRCLE (xmax / 2, ymax / 2), 330 + r, _RGB32(100 + 5 * r, 100 + 5 * r, 100 + 5 * r)
  178.     NEXT
  179.     CIRCLE (xmax / 2, ymax / 2), 408, _RGB32(204, 205, 205)
  181.  
Title: Re: Morph Curve
Post by: Pete on January 29, 2019, 12:53:58 pm
No offense, but that looks more like a cherry pie, and the lattice crust is starting to mold. Oh well, meatballs, pie, what's the difference? I suppose one way you'd be thought of as a master cooker and the other way, well...

Definitely a short-order cook / baker, regardless!

Pete :D 
Title: Re: Morph Curve
Post by: bplus on January 29, 2019, 04:27:13 pm
OK, not meatballs just a plate decoration. Here is the table set:
Title: Re: Morph Curve
Post by: johnno56 on January 29, 2019, 10:32:50 pm
What?!? No cheese!?

Can you do a roast chicken? oh, or even better, Lasagne... Mmmm...
Title: Re: Morph Curve
Post by: Pete on January 30, 2019, 12:44:16 am
Yeah Mark. Get in the kitchen and code me a sweater!

Pete :D
Text Only | Text with Attachments