Gears

[bplus]

Sure beats my JB version!

Code: QB64: [Select]

1. _TITLE "Gear 1.bas for QB64 by B+ started  2018-05-22"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3. CONST xmax = 800
4. CONST ymax = 600
5. DIM SHARED pi
6. pi = _PI
7. CONST bhr = 20
8. SCREEN _NEWIMAGE(xmax, ymax, 32)
9. _SCREENMOVE 360, 60
10. sq = 20
11. nt1 = 16
12. k1 = _RGB32(250, 150, 0)
13. r1 = gearRadius(nt1, sq)
14. nt2 = nt1 * 2
15. k2 = _RGB32(255, 255, 0)
16. r2 = gearRadius(nt2, sq)
17. iA2 = pi / nt2
18. FOR rao = 0 TO pi * 2 STEP pi / 180
19.     CLS
20.     gear 600, 300, nt1, sq, rao, k1
21.     gear 600 - r1 - r2 - sq, 300, nt2, sq, -.5 * rao - iA2, k2
22.     _DISPLAY
23.     _LIMIT 25
24. NEXT
25.  
26. FUNCTION gearRadius (nteeth, sqtooth)
27.     gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
28. END FUNCTION
29.  
30. SUB gear (x, y, nteeth, sqtooth, raOffset, K AS _UNSIGNED LONG)
31.     radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
32.     FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
33.         x2 = x + (radius + sqtooth) * COS(ra + raOffset)
34.         y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
35.         thic x, y, x2, y2, sqtooth, K
36.     NEXT
37.     'to speed things up and reduce blicking just do a circle fill x, y already set and pen color too
38.     FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
39.         x2 = x + radius * COS(ra + raOffset)
40.         y2 = y + radius * SIN(ra + raOffset)
41.         thic x, y, x2, y2, sqtooth, K
42.     NEXT
43.     COLOR _RGB32(155, 70, 35)
44.     fcirc x, y, .9 * radius
45.     K1 = _RGB(0, 0, 0)
46.     COLOR K1
47.     fcirc x, y, bhr
48.     thic x, y, x + (bhr + sqtooth) * COS(raOffset), y + (bhr + sqtooth) * SIN(raOffset), sqtooth, K1
49. END SUB
50.  
51. SUB thic (x1, y1, x2, y2, thick, K AS _UNSIGNED LONG)
52.     t2 = thick / 2
53.     IF t2 < 1 THEN t2 = 1
54.     a = _ATAN2(y2 - y1, x2 - x1)
55.     x3 = x1 + t2 * COS(a + _PI(.5))
56.     y3 = y1 + t2 * SIN(a + _PI(.5))
57.     x4 = x1 + t2 * COS(a - _PI(.5))
58.     y4 = y1 + t2 * SIN(a - _PI(.5))
59.     x5 = x2 + t2 * COS(a + _PI(.5))
60.     y5 = y2 + t2 * SIN(a + _PI(.5))
61.     x6 = x2 + t2 * COS(a - _PI(.5))
62.     y6 = y2 + t2 * SIN(a - _PI(.5))
63.     filltri x6, y6, x4, y4, x3, y3, K
64.     filltri x3, y3, x5, y5, x6, y6, K
65. END SUB
66.  
67.  
68. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
69. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
70.     DIM subRadius AS LONG, RadiusError AS LONG
71.     DIM X AS LONG, Y AS LONG
72.  
73.     subRadius = ABS(R)
74.     RadiusError = -subRadius
75.     X = subRadius
76.     Y = 0
77.  
78.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
79.  
80.     ' Draw the middle span here so we don't draw it twice in the main loop,
81.     ' which would be a problem with blending turned on.
82.     LINE (CX - X, CY)-(CX + X, CY), , BF
83.  
84.     WHILE X > Y
85.         RadiusError = RadiusError + Y * 2 + 1
86.         IF RadiusError >= 0 THEN
87.             IF X <> Y + 1 THEN
88.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
89.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
90.             END IF
91.             X = X - 1
92.             RadiusError = RadiusError - X * 2
93.         END IF
94.         Y = Y + 1
95.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
96.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
97.     WEND
98. END SUB
99.  
100. ' 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
101. SUB filltri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
102.     a& = _NEWIMAGE(1, 1, 32)
103.     _DEST a&
104.     PSET (0, 0), K
105.     _DEST 0
106.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
107.     _FREEIMAGE a& '<<< this is important!
108. END SUB
109.  

[Ashish]

Good work, bplus!
Here's a my mod -

Code: QB64: [Select]

1. _TITLE "Gear 1.bas for QB64 by B+ started  2018-05-22"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3. CONST xmax = 800
4. CONST ymax = 600
5. DIM SHARED pi
6. pi = _PI
7. CONST bhr = 20
8. SCREEN _NEWIMAGE(xmax, ymax, 32)
9. _SCREENMOVE 360, 60
10. sq = 20
11. nt1 = 16
12. k1 = _RGB32(250, 150, 0)
13. r1 = gearRadius(nt1, sq)
14. nt2 = nt1 * 2
15. k2 = _RGB32(255, 255, 0)
16. r2 = gearRadius(nt2, sq)
17. iA2 = pi / nt2
18. DO
19.     CLS
20.     gear 600, 300, nt1, sq, rao, k1
21.     gear 600 - r1 - r2 - sq, 300, nt2, sq, -.5 * rao - iA2, k2
22.     _DISPLAY
23.     rao = rao + .001
24. LOOP UNTIL INKEY$ <> ""
25. FUNCTION gearRadius (nteeth, sqtooth)
26.     gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
27. END FUNCTION
28.  
29. SUB gear (x, y, nteeth, sqtooth, raOffset, K AS _UNSIGNED LONG)
30.     radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
31.     'FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
32.     '    x2 = x + (radius + sqtooth) * COS(ra + raOffset)
33.     '    y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
34.     '    thic x, y, x2, y2, sqtooth, K
35.     'NEXT
36.     angOff = .25
37.     FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
38.         x1 = COS(ra - (angOff / 2) + raOffset) * (radius * .8) + x
39.         y1 = SIN(ra - (angOff / 2) + raOffset) * (radius * .8) + y
40.         x2 = COS(ra + (angOff / 2) + raOffset) * (radius * .8) + x
41.         y2 = SIN(ra + (angOff / 2) + raOffset) * (radius * .8) + y
42.         x3 = COS(ra + raOffset) * (radius * 1.15) + x
43.         y3 = SIN(ra + raOffset) * (radius * 1.15) + y
44.         filltri x1, y1, x2, y2, x3, y3, K
45.     NEXT
46.  
47.     'to speed things up and reduce blicking just do a circle fill x, y already set and pen color too
48.     'FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
49.     '    x2 = x + radius * COS(ra + raOffset)
50.     '    y2 = y + radius * SIN(ra + raOffset)
51.     '    thic x, y, x2, y2, sqtooth, K
52.     'NEXT
53.     COLOR _RGB32(155, 70, 35)
54.     fcirc x, y, .9 * radius
55.     K1 = _RGB(0, 0, 0)
56.     COLOR K1
57.     fcirc x, y, bhr
58.     thic x, y, x + (bhr + sqtooth) * COS(raOffset), y + (bhr + sqtooth) * SIN(raOffset), sqtooth, K1
59. END SUB
60.  
61. SUB thic (x1, y1, x2, y2, thick, K AS _UNSIGNED LONG)
62.     t2 = thick / 2
63.     IF t2 < 1 THEN t2 = 1
64.     a = _ATAN2(y2 - y1, x2 - x1)
65.     x3 = x1 + t2 * COS(a + _PI(.5))
66.     y3 = y1 + t2 * SIN(a + _PI(.5))
67.     x4 = x1 + t2 * COS(a - _PI(.5))
68.     y4 = y1 + t2 * SIN(a - _PI(.5))
69.     x5 = x2 + t2 * COS(a + _PI(.5))
70.     y5 = y2 + t2 * SIN(a + _PI(.5))
71.     x6 = x2 + t2 * COS(a - _PI(.5))
72.     y6 = y2 + t2 * SIN(a - _PI(.5))
73.     filltri x6, y6, x4, y4, x3, y3, K
74.     filltri x3, y3, x5, y5, x6, y6, K
75. END SUB
76.  
77.  
78. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
79. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
80.     DIM subRadius AS LONG, RadiusError AS LONG
81.     DIM X AS LONG, Y AS LONG
82.  
83.     subRadius = ABS(R)
84.     RadiusError = -subRadius
85.     X = subRadius
86.     Y = 0
87.  
88.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
89.  
90.     ' Draw the middle span here so we don't draw it twice in the main loop,
91.     ' which would be a problem with blending turned on.
92.     LINE (CX - X, CY)-(CX + X, CY), , BF
93.  
94.     WHILE X > Y
95.         RadiusError = RadiusError + Y * 2 + 1
96.         IF RadiusError >= 0 THEN
97.             IF X <> Y + 1 THEN
98.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
99.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
100.             END IF
101.             X = X - 1
102.             RadiusError = RadiusError - X * 2
103.         END IF
104.         Y = Y + 1
105.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
106.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
107.     WEND
108. END SUB
109.  
110. ' 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
111. SUB filltri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
112.     a& = _NEWIMAGE(1, 1, 32)
113.     _DEST a&
114.     PSET (0, 0), K
115.     _DEST 0
116.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
117.     _FREEIMAGE a& '<<< this is important!
118. END SUB
119.  
120.  

[bplus]

Code: QB64: [Select]

1. _TITLE "Double Eclipse: Gear mod Ashish mod again  by B+ started  2018-05-23"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3. CONST xmax = 800
4. CONST ymax = 600
5. DIM SHARED pi
6. pi = _PI
7. CONST bhr = 20
8. SCREEN _NEWIMAGE(xmax, ymax, 32)
9. _SCREENMOVE 360, 60
10. sq = 20
11. nt1 = 16
12. k1& = _RGB32(150, 150, 150)
13. r1 = gearRadius(nt1, sq)
14. nt2 = nt1 * 2
15. k2& = _RGB32(255, 255, 100)
16. r2 = gearRadius(nt2, sq)
17. iA2 = pi / nt2
18. DO
19.     CLS
20.     gear 600, 300, nt1, sq, rao, k1&
21.     gear 600 - r1 - r2 - sq, 300, nt2, sq, -.5 * rao - iA2, k2&
22.     _DISPLAY
23.     rao = rao + .001
24. LOOP UNTIL INKEY$ <> ""
25. FUNCTION gearRadius (nteeth, sqtooth)
26.     gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
27. END FUNCTION
28.  
29. SUB gear (x, y, nteeth, sqtooth, raOffset, K AS _UNSIGNED LONG)
30.     radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
31.     'FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
32.     '    x2 = x + (radius + sqtooth) * COS(ra + raOffset)
33.     '    y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
34.     '    thic x, y, x2, y2, sqtooth, K
35.     'NEXT
36.     angOff = .25
37.     FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
38.         x1 = COS(ra - (angOff / 2) + raOffset) * (radius * .8) + x
39.         y1 = SIN(ra - (angOff / 2) + raOffset) * (radius * .8) + y
40.         x2 = COS(ra + (angOff / 2) + raOffset) * (radius * .8) + x
41.         y2 = SIN(ra + (angOff / 2) + raOffset) * (radius * .8) + y
42.         x3 = COS(ra + raOffset) * (radius * 1.15) + x
43.         y3 = SIN(ra + raOffset) * (radius * 1.15) + y
44.         filltri x1, y1, x2, y2, x3, y3, K
45.     NEXT
46.  
47.     'to speed things up and reduce blicking just do a circle fill x, y already set and pen color too
48.     'FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
49.     '    x2 = x + radius * COS(ra + raOffset)
50.     '    y2 = y + radius * SIN(ra + raOffset)
51.     '    thic x, y, x2, y2, sqtooth, K
52.     'NEXT
53.     'COLOR _RGB32(155, 70, 35)
54.     'fcirc x, y, .9 * radius
55.     'K1 = _RGB(0, 0, 0)
56.     'COLOR K1
57.     'fcirc x, y, bhr
58.     'thic x, y, x + (bhr + sqtooth) * COS(raOffset), y + (bhr + sqtooth) * SIN(raOffset), sqtooth, K1
59. END SUB
60.  
61. SUB thic (x1, y1, x2, y2, thick, K AS _UNSIGNED LONG)
62.     t2 = thick / 2
63.     IF t2 < 1 THEN t2 = 1
64.     a = _ATAN2(y2 - y1, x2 - x1)
65.     x3 = x1 + t2 * COS(a + _PI(.5))
66.     y3 = y1 + t2 * SIN(a + _PI(.5))
67.     x4 = x1 + t2 * COS(a - _PI(.5))
68.     y4 = y1 + t2 * SIN(a - _PI(.5))
69.     x5 = x2 + t2 * COS(a + _PI(.5))
70.     y5 = y2 + t2 * SIN(a + _PI(.5))
71.     x6 = x2 + t2 * COS(a - _PI(.5))
72.     y6 = y2 + t2 * SIN(a - _PI(.5))
73.     filltri x6, y6, x4, y4, x3, y3, K
74.     filltri x3, y3, x5, y5, x6, y6, K
75. END SUB
76.  
77.  
78. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
79. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
80.     DIM subRadius AS LONG, RadiusError AS LONG
81.     DIM X AS LONG, Y AS LONG
82.  
83.     subRadius = ABS(R)
84.     RadiusError = -subRadius
85.     X = subRadius
86.     Y = 0
87.  
88.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
89.  
90.     ' Draw the middle span here so we don't draw it twice in the main loop,
91.     ' which would be a problem with blending turned on.
92.     LINE (CX - X, CY)-(CX + X, CY), , BF
93.  
94.     WHILE X > Y
95.         RadiusError = RadiusError + Y * 2 + 1
96.         IF RadiusError >= 0 THEN
97.             IF X <> Y + 1 THEN
98.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
99.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
100.             END IF
101.             X = X - 1
102.             RadiusError = RadiusError - X * 2
103.         END IF
104.         Y = Y + 1
105.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
106.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
107.     WEND
108. END SUB
109.  
110. ' 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
111. SUB filltri (x1, y1, x2, y2, x3, y3, K AS _UNSIGNED LONG)
112.     a& = _NEWIMAGE(1, 1, 32)
113.     _DEST a&
114.     PSET (0, 0), K
115.     _DEST 0
116.     _MAPTRIANGLE _SEAMLESS(0, 0)-(0, 0)-(0, 0), a& TO(x1, y1)-(x2, y2)-(x3, y3)
117.     _FREEIMAGE a& '<<< this is important!
118. END SUB
119.  
120.  

[bplus]

hmm... I am thinking of belt drives.

Draw 2 lines tangent to 2 circles with different radii and variable distance apart...

hmm...

[_vince]

Neat problem getting them aligned, I've come across it before:

Code: QB64: [Select]

1. screen 12
2.  
3. dim shared pi,ss,a
4. pi = 4*atn(1)
5. b = pi/2
6. ss = 5*pi
7. rr = 200
8. r = 80
9. do
10.         'do
11.         '       mx = _mousex
12.         '       my = _mousey
13.         'loop while _mouseinput
14.         'r = sqr((mx-320)^2+(my-240)^2)
15.  
16.         t=t+0.02
17.         line(0,0)-(640,480),0,bf
18.  
19.         b = pi/2 + (r/(rr-r))*t
20.         x = 320 + (rr-r)*cos(b)
21.         y = 240 + (rr-r)*sin(b)
22.  
23.         gear 320, 240, rr, pi/2
24.         gear 320 + (rr-r)*cos(b), 240 + (rr-r)*sin(b), r, pi/2 -t
25.  
26.         _display
27.         _limit 50
28.  
29. loop until _keyhit = -27
30. system
31.  
32. sub gear (x0, y0, r, b as double)
33.         dim a as double
34.         dim s as double
35.  
36.         s = ss/r
37.  
38.         pset (x0 + r*cos(b), y0 + r*sin(b))
39.  
40.         for a = b to b + 2*pi+s step s
41.                 x = x0 + r*cos(a)
42.                 y = y0 + r*sin(a)
43.                 line -(x,y)
44.                 x = x0 + (r+ss)*cos(a+s/2)
45.                 y = y0 + (r+ss)*sin(a+s/2)
46.                 line -(x,y)
47.         next
48. end sub
49.  

[bplus]

Oh hey! That's the Spiro-graph. :)

Those teeth do fit very well!

I was going to trim the corners off my gears, lookup the blueprints again for a gear...

[bplus]

Gears Afire!

Code: QB64: [Select]

1. _TITLE "Gears afire!.bas for QB64 by B+ started  2018-05-24"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3.  
4. CONST xmax = 800
5. CONST ymax = 600
6. DIM SHARED pi
7. pi = _PI
8. CONST bhr = 20
9. SCREEN _NEWIMAGE(xmax, ymax, 32)
10. _SCREENMOVE 360, 60
11.  
12. DIM SHARED f(xmax, ymax) 'fire array tracks flames
13. DIM SHARED p&(300) 'pallette thanks harixxx
14. FOR i = 1 TO 100
15.     fr = 240 * i / 100 + 15
16.     p&(i) = _RGB(fr, 0, 0)
17.     p&(i + 100) = _RGB(255, fr, 0)
18.     p&(i + 200) = _RGB(255, 255, fr)
19. NEXT
20.  
21. 'gear up
22. sq = 20
23. nt1 = 12
24. r1 = gearRadius(nt1, sq)
25. nt2 = nt1 * 2
26. r2 = gearRadius(nt2, sq)
27. iA2 = pi / nt2
28. acc = 300: d = -1
29. WHILE 1 'main show
30.     CLS
31.     rao = rao + pi / acc
32.     gear 600, 300, nt1, sq, rao
33.     gear 600 - r1 - r2 - sq - 6, 300, nt2, sq, -.5 * rao - iA2
34.     FOR y = 1 TO ymax - 2 'fire based literally on 4 pixels below it like cellular automata
35.         FOR x = 1 TO xmax - 1
36.             v = (f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 5
37.             IF v > 0 AND RND < .96 THEN f(x, y) = v ELSE f(x, y) = 0
38.             IF v > 294 THEN f(x, y) = 300
39.             PSET (x, y), p&(f(x, y))
40.         NEXT
41.     NEXT
42.     acc = acc + d * 2
43.     IF acc < 6 THEN acc = 6: d = d * -1
44.     IF acc > 300 THEN acc = 300: d = d * -1
45.     _DISPLAY
46. WEND
47.  
48. FUNCTION gearRadius (nteeth, sqtooth)
49.     gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
50. END FUNCTION
51.  
52. SUB gear (x, y, nteeth, sqtooth, raOffset)
53.     radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
54.     FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
55.         x2 = x + (radius + sqtooth) * COS(ra + raOffset)
56.         y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
57.         thic x, y, x2, y2, sqtooth - 4
58.     NEXT
59.     FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
60.         x2 = x + radius * COS(ra + raOffset)
61.         y2 = y + radius * SIN(ra + raOffset)
62.         thic x, y, x2, y2, sqtooth + 4
63.     NEXT
64. END SUB
65.  
66. SUB thic (x1, y1, x2, y2, thick)
67.     t2 = thick / 2
68.     IF t2 < 1 THEN t2 = 1
69.     a = _ATAN2(y2 - y1, x2 - x1)
70.     FOR i = 0 TO t2 STEP .5
71.         x3 = x1 + i * COS(a + _PI(.5))
72.         y3 = y1 + i * SIN(a + _PI(.5))
73.         x4 = x1 + i * COS(a - _PI(.5))
74.         y4 = y1 + i * SIN(a - _PI(.5))
75.         x5 = x2 + i * COS(a + _PI(.5))
76.         y5 = y2 + i * SIN(a + _PI(.5))
77.         x6 = x2 + i * COS(a - _PI(.5))
78.         y6 = y2 + i * SIN(a - _PI(.5))
79.         'fireLine x3, y3, x4, y4
80.         fireLine x4, y4, x6, y6
81.         'fireLine x6, y6, x5, y5
82.         fireLine x5, y5, x3, y3
83.     NEXT
84. END SUB
85.  
86. SUB fireLine (x, y, x1, y1)
87.     d = ((x - x1) ^ 2 + (y - y1) ^ 2) ^ .5
88.     a = _ATAN2(y1 - y, x1 - x)
89.     FOR i = 0 TO d
90.         xx = INT(x + i * COS(a) + .5)
91.         yy = INT(y + i * SIN(a) + .5)
92.         f(xx, yy) = rand(200, 300)
93.     NEXT
94. END SUB
95.  
96. FUNCTION rand% (lo%, hi%)
97.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
98. END FUNCTION
99.  

EDIT: removed an unused parameter in fileLine

[FellippeHeitor]

Now that's what I call a crossover.

Can it be made any faster though?

[bplus]

Speed up? I wish! You did wait to see the gears speed up and slow down and speed up.... right?

Maybe Steve or someone could do memory tricks, I am drawing lines pixel by pixel in a psuedo screen array.

I did consider scaling the f for fire array.

Append: ha! I could get rid of that extra parameter thick, not used in fireLine!

Append again, possibly could be done with POINT before clearing screen, that way all the hand draw stuff could be done with built-in commands. You do need some "slow" to let the fire effect "accumulate" in the pixels in surrounding area.

[FellippeHeitor]

Speed up? I wish! You did wait to see the gears speed up and slow down and speed up.... right?

Hmm didn't. Low fps at start put me off. Looked in code for usual _delay and upon not finding it I assumed it was loooow fps

[bplus]

Hi Fellippe,

For you, I will show you one of my blunders but kind of cool too! It may show why you do have to go a little slow with fire.

Code: QB64: [Select]

1. _TITLE "Ferris Wheels Afire!.bas for QB64 by B+ started  2018-05-24"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3.  
4. CONST xmax = 800
5. CONST ymax = 600
6. DIM SHARED pi
7. pi = _PI
8. CONST bhr = 20
9. SCREEN _NEWIMAGE(xmax, ymax, 32)
10. _SCREENMOVE 360, 60
11.  
12. DIM SHARED f(xmax, ymax) 'fire array tracks flames
13. DIM SHARED p&(300) 'pallette thanks harixxx
14. FOR i = 1 TO 100
15.     fr = 240 * i / 100 + 15
16.     p&(i) = _RGB(fr, 0, 0)
17.     p&(i + 100) = _RGB(255, fr, 0)
18.     p&(i + 200) = _RGB(255, 255, fr)
19. NEXT
20.  
21. 'gear up
22. sq = 20
23. nt1 = 12
24. r1 = gearRadius(nt1, sq)
25. nt2 = nt1 * 2
26. r2 = gearRadius(nt2, sq)
27. iA2 = pi / nt2
28. acc = 300: d = -1
29. WHILE 1 'main show
30.     CLS
31.     rao = rao + pi / acc
32.     gear 600, 300, nt1, sq, rao
33.     gear 600 - r1 - r2 - sq - 6, 300, nt2, sq, -.5 * rao - iA2
34.     FOR y = 1 TO ymax - 2 'fire based literally on 4 pixels below it like cellular automata
35.         FOR x = 1 TO xmax - 1
36.             v = (f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 5
37.             IF v > 0 AND RND < .96 THEN f(x, y) = v ELSE f(x, y) = 0
38.             IF v > 294 THEN f(x, y) = 300
39.             PSET (x, y), p&(f(x, y))
40.         NEXT
41.     NEXT
42.     acc = acc + d * 2
43.     IF acc < 6 THEN acc = 6: d = d * -1
44.     IF acc > 300 THEN acc = 300: d = d * -1
45.     _DISPLAY
46. WEND
47.  
48. FUNCTION gearRadius (nteeth, sqtooth)
49.     gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
50. END FUNCTION
51.  
52. SUB gear (x, y, nteeth, sqtooth, raOffset)
53.     radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
54.     FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
55.         x2 = x + (radius + sqtooth) * COS(ra + raOffset)
56.         y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
57.         thic x, y, x2, y2, sqtooth - 4
58.     NEXT
59.     FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
60.         x2 = x + radius * COS(ra + raOffset)
61.         y2 = y + radius * SIN(ra + raOffset)
62.         thic x, y, x2, y2, sqtooth + 4
63.     NEXT
64. END SUB
65.  
66. SUB thic (x1, y1, x2, y2, thick)
67.     t2 = thick / 2
68.     IF t2 < 1 THEN t2 = 1
69.     a = _ATAN2(y2 - y1, x2 - x1)
70.     FOR i = 0 TO t2 STEP .5
71.         x3 = x1 + t2 * COS(a + _PI(.5))
72.         y3 = y1 + t2 * SIN(a + _PI(.5))
73.         x4 = x1 + t2 * COS(a - _PI(.5))
74.         y4 = y1 + t2 * SIN(a - _PI(.5))
75.         x5 = x2 + t2 * COS(a + _PI(.5))
76.         y5 = y2 + t2 * SIN(a + _PI(.5))
77.         x6 = x2 + t2 * COS(a - _PI(.5))
78.         y6 = y2 + t2 * SIN(a - _PI(.5))
79.         fireLine x3, y3, x4, y4
80.         fireLine x4, y4, x6, y6
81.         fireLine x6, y6, x5, y5
82.         fireLine x5, y5, x3, y3
83.     NEXT
84. END SUB
85.  
86. SUB fireLine (x, y, x1, y1)
87.     d = ((x - x1) ^ 2 + (y - y1) ^ 2) ^ .5
88.     a = _ATAN2(y1 - y, x1 - x)
89.     FOR i = 0 TO d
90.         xx = INT(x + i * COS(a) + .5)
91.         yy = INT(y + i * SIN(a) + .5)
92.         f(xx, yy) = rand(200, 300)
93.     NEXT
94. END SUB
95.  
96. FUNCTION rand% (lo%, hi%)
97.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
98. END FUNCTION
99.  

[Ashish]

Now, this is something cool!
For speeding up, you can try reducing screen size.

[bplus]

To speed up, you can reduce screen size OR scale the pixel drawing up to boxes. Either way, there is less calculations.
Of course, you can also rotate the gears faster and slower as demo'd already. ;-))

Here is doing it with scaling, the smaller the scale the bigger the fire but the blurrier the picture. Try any scale >0 and <=1:

Code: QB64: [Select]

1. _TITLE "Gears Afire! SCALED.bas for QB64 by B+ started  2018-05-25"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3.  
4. CONST xmax = 800
5. CONST ymax = 600
6. DIM SHARED pi
7. pi = _PI
8.  
9. SCREEN _NEWIMAGE(xmax, ymax, 32)
10. _SCREENMOVE 360, 60
11. DIM SHARED p&(300) 'pallette thanks harixxx
12. FOR i = 1 TO 100
13.     fr = 240 * i / 100 + 15
14.     p&(i) = _RGB(fr, 0, 0)
15.     p&(i + 100) = _RGB(255, fr, 0)
16.     p&(i + 200) = _RGB(255, 255, fr)
17. NEXT
18.  
19. WHILE 1
20.     CLS
21.     LOCATE 5, 23: PRINT "***  GEARS AFIRE! NOW SCALED TO YOUR SPECIFICATIONS ***"
22.     LOCATE 10, 35: PRINT "Please enter a scale from 0 to 1,"
23.     LOCATE 11, 10: PRINT "the lower the scale the less pixels used the bigger the fire and blurrier it gets. "
24.     LOCATE 13, 20: INPUT "(0 or any number > 1 quits) Enter your scale choice now > "; scale
25.     _DISPLAY
26.     IF NOT (scale > 0 AND scale <= 1) THEN END
27.     CLS
28.  
29.     LOCATE 10, 18: PRINT "Please wait 30 seconds to watch the _LIMIT changes for graphics speed."
30.     LOCATE 15, 41: PRINT "press any for show..."
31.     _DISPLAY
32.     'SLEEP      'WTF???
33.     k$ = ""
34.     WHILE LEN(k$) = 0: k$ = INKEY$: _LIMIT 500: WEND
35.  
36.  
37.     rscale = 1 / scale
38.     xxmax = scale * xmax
39.     yymax = scale * ymax
40.  
41.     REDIM SHARED f(xxmax, yymax) 'fire array tracks flames
42.  
43.     'gear up
44.     sq = 20
45.     nt1 = 12
46.     r1 = gearRadius(nt1, sq)
47.     nt2 = nt1 * 2
48.     r2 = gearRadius(nt2, sq)
49.     iA2 = pi / nt2
50.     acc = 1: d = 1
51.  
52.     start = TIMER
53.     WHILE TIMER - start < 30 'main show
54.         CLS
55.         PRINT "Scale, _LIMIT:"; scale; ","; acc
56.         rao = rao + pi / 180
57.         gear 600 * scale + 1, 300 * scale + 1, nt1, sq * scale, rao
58.         gear (600 - r1 - r2 - sq - 6) * scale + 1, 300 * scale + 1, nt2, sq * scale, -.5 * rao - iA2
59.         FOR y = 1 TO yymax - 2 'fire based literally on 4 pixels below it like cellular automata
60.             FOR x = 1 TO xxmax - 1
61.                 v = (f(x - 1, y + 1) + f(x, y + 1) + f(x + 1, y + 1) + f(x, y + 2)) / 4 - 5
62.                 IF v > 0 AND RND < .96 THEN f(x, y) = v ELSE f(x, y) = 0
63.                 IF v > 294 THEN f(x, y) = 300
64.                 LINE (x * rscale, y * rscale)-STEP(rscale, rscale), p&(f(x, y)), BF
65.             NEXT
66.         NEXT
67.         acc = acc + d
68.         IF acc < 1 THEN acc = 1: d = d * -1
69.         IF acc > 100 THEN acc = 100: d = d * -1
70.         _DISPLAY
71.         _LIMIT acc
72.     WEND
73. WEND
74.  
75.  
76. FUNCTION gearRadius (nteeth, sqtooth)
77.     gearRadius = .5 * sqtooth / SIN(.5 * pi / nteeth)
78. END FUNCTION
79.  
80. SUB gear (x, y, nteeth, sqtooth, raOffset)
81.     radius = .5 * sqtooth / SIN(.5 * pi / nteeth)
82.     FOR ra = 0 TO 2 * pi STEP 2 * pi / nteeth
83.         x2 = x + (radius + sqtooth) * COS(ra + raOffset)
84.         y2 = y + (radius + sqtooth) * SIN(ra + raOffset)
85.         thic x, y, x2, y2, sqtooth - 4
86.     NEXT
87.     FOR ra = pi / nteeth TO 2 * pi STEP 2 * pi / nteeth
88.         x2 = x + radius * COS(ra + raOffset)
89.         y2 = y + radius * SIN(ra + raOffset)
90.         thic x, y, x2, y2, sqtooth + 4
91.     NEXT
92. END SUB
93.  
94. SUB thic (x1, y1, x2, y2, thick)
95.     t2 = thick / 2
96.     IF t2 < 1 THEN t2 = 1
97.     a = _ATAN2(y2 - y1, x2 - x1)
98.     FOR i = 0 TO t2 STEP .5
99.         x3 = x1 + i * COS(a + _PI(.5))
100.         y3 = y1 + i * SIN(a + _PI(.5))
101.         x4 = x1 + i * COS(a - _PI(.5))
102.         y4 = y1 + i * SIN(a - _PI(.5))
103.         x5 = x2 + i * COS(a + _PI(.5))
104.         y5 = y2 + i * SIN(a + _PI(.5))
105.         x6 = x2 + i * COS(a - _PI(.5))
106.         y6 = y2 + i * SIN(a - _PI(.5))
107.         'fireLine x3, y3, x4, y4
108.         fireLine x4, y4, x6, y6
109.         'fireLine x6, y6, x5, y5
110.         fireLine x5, y5, x3, y3
111.     NEXT
112. END SUB
113.  
114. SUB fireLine (x, y, x1, y1)
115.     d = ((x - x1) ^ 2 + (y - y1) ^ 2) ^ .5
116.     a = _ATAN2(y1 - y, x1 - x)
117.     FOR i = 0 TO d
118.         xx = INT(x + i * COS(a) + .5)
119.         yy = INT(y + i * SIN(a) + .5)
120.         f(xx, yy) = rand(200, 300)
121.     NEXT
122. END SUB
123.  
124. FUNCTION rand% (lo%, hi%)
125.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
126. END FUNCTION
127.  
128.  

[Ashish]

Now, this runs smoothly with .5 as scale level. :)

[bplus]

;) I was hoping for that!