QB64.org Forum

Active Forums => Programs => Topic started by: _vince on February 15, 2018, 06:52:14 pm

Title: Chaotic scattering
Post by: _vince on February 15, 2018, 06:52:14 pm

https://en.wikipedia.org/wiki/Chaotic_scattering (https://en.wikipedia.org/wiki/Chaotic_scattering)

Demo of the Gaspard-Rice system as described above.  Left-click to change location.

Code: QB64: [Select]

1. defint a-z
2. sw = 640
3. sh = 480
4. dim pi as double
5. dim t as double
6. dim a as double, b as double
7. dim a1 as double, a2 as double
8.  
9. dim x as double, y as double
10. dim x0 as double, y0 as double
11. dim x1 as double, y1 as double
12.  
13. pi = 3.141593
14.  
15. screen _newimage(sw,sh,12)
16.  
17. r = 150
18. rr = 100
19.  
20. 'line(0,0)-(sw,sh),0,bf
21. 'for b=0 to 2*pi step 2*pi/3
22. '       circle (r*cos(b)+sw/2, r*sin(b)+sh/2),rr
23. 'next
24. 'end
25.  
26. xx = sw/2
27. yy = sh/2
28.  
29. do
30.         do
31.                 mx=_mousex
32.                 my=_mousey
33.                 mb=_mousebutton(1)
34.         loop while _mouseinput
35.  
36.         line(0,0)-(sw,sh),0,bf
37.         for b=0 to 2*pi step 2*pi/3
38.                 circle (r*cos(b)+sw/2, r*sin(b)+sh/2),rr
39.         next
40.  
41.  
42.         if mb then
43.                 f = -1
44.                 do while mb
45.                         do
46.                                 mb=_mousebutton(1)
47.                         loop while _mouseinput
48.                 loop
49.                 for b=0 to 2*pi step 2*pi/3
50.                         x1=r*cos(b)+sw/2
51.                         y1=r*sin(b)+sh/2
52.                         if (mx-x1)^2+(my-y1)^2 < rr*rr then f = 0
53.                 next
54.                 if f then
55.                         xx = mx
56.                         yy = my
57.                         f = -1
58.                 end if
59.         end if
60.  
61.         x0 = xx
62.         y0 = yy
63.  
64.         a = _atan2(my-yy,mx-xx)
65.  
66.         t=0
67.         do
68.                 t=t+1
69.                 x = t*cos(a)+x0
70.                 y = t*sin(a)+y0
71.                 if x<0 or x>sw or y<0 or y>sh then exit do
72.                 for b=0 to 2*pi step 2*pi/3
73.                         x1=r*cos(b)+sw/2
74.                         y1=r*sin(b)+sh/2
75.                         if (x-x1)^2+(y-y1)^2 < rr*rr then
76.                                 a1 = _atan2(y-y1,x-x1)
77.                                 a2 = 2*a1-a-pi
78.  
79.                                 line(x0, y0)-(x,y),14
80.  
81.                                 x0 = x
82.                                 y0 = y
83.                                 a = a2
84.                                 t=0
85.                                 exit for
86.                         end if
87.                 next
88.         loop
89.  
90.         line (x0,y0)-(x,y),14
91.  
92.         _display
93.         _limit 50
94. loop until _keyhit=27
95. system
96.  

Title: Re: Chaotic scattering
Post by: bplus on February 15, 2018, 07:03:36 pm

This is neat! I just thought of something we might do to make this even more interesting!

Title: Re: Chaotic scattering
Post by: FellippeHeitor on February 15, 2018, 08:30:19 pm

This one always keeps me playing. Great job as always, v.

PS: What about that slow fading of the lasers in the laser show room that was added the other day? Scraped for good?

Title: Re: Chaotic scattering
Post by: bplus on February 15, 2018, 09:44:45 pm

Finally got the cool mod I had in mind working:

Code: QB64: [Select]

1. _TITLE "*** Chaotic Scattering *** by vince and mod by bplus 2018-02-15                     click mouse to reset LASER"
2. DEFINT A-Z
3. RANDOMIZE TIMER
4. CONST sw = 1200
5. CONST sh = 700
6.  
7. DIM SHARED qb(15) AS _INTEGER64
8. qb(0) = &HFF000000
9. qb(1) = &HFF000088
10. qb(2) = &HFF008800
11. qb(3) = &HFF008888
12. qb(4) = &HFF880000
13. qb(5) = &HFF880088
14. qb(6) = &HFF888800
15. qb(7) = &HFFCCCCCC
16. qb(8) = &HFF888888
17. qb(9) = &HFF0000FF
18. qb(10) = &HFF00FF00
19. qb(11) = &HFF00FFFF
20. qb(12) = &HFFFF0000
21. qb(13) = &HFFFF00FF
22. qb(14) = &HFFFFFF00
23. qb(15) = &HFFFFFFFF
24.  
25. CONST nCircs = 25
26. CONST r = 150
27. CONST maxr = 100
28. TYPE circles
29.     x AS INTEGER
30.     y AS INTEGER
31.     r AS INTEGER
32.     c AS _INTEGER64
33. END TYPE
34. DIM SHARED cs(nCircs) AS circles
35. DIM i AS INTEGER
36. DIM c AS INTEGER
37. DIM ck AS INTEGER
38. FOR i = 1 TO nCircs
39.     cs(i).r = RND * (maxr - 20) + 20
40.     cs(i).c = qb(INT(RND * 15) + 1)
41.     IF i > 1 THEN
42.         ck = 0
43.         WHILE ck = 0
44.             cs(i).x = INT(RND * (sw - 2 * cs(i).r)) + cs(i).r
45.             cs(i).y = INT(RND * (sh - 2 * cs(i).r)) + cs(i).r
46.             ck = 1
47.             FOR c = 1 TO i - 1
48.                 IF ((cs(i).x - cs(c).x) ^ 2 + (cs(i).y - cs(c).y) ^ 2) ^ .5 < cs(i).r + cs(c).r THEN ck = 0: EXIT FOR
49.             NEXT
50.         WEND
51.     ELSE
52.         cs(i).x = INT(RND * (sw - 2 * cs(i).r)) + cs(i).r
53.         cs(i).y = INT(RND * (sh - 2 * cs(i).r)) + cs(i).r
54.     END IF
55. NEXT
56.  
57. DIM t AS DOUBLE
58. DIM a AS DOUBLE, b AS DOUBLE
59. DIM a1 AS DOUBLE, a2 AS DOUBLE
60.  
61. DIM x AS DOUBLE, y AS DOUBLE
62. DIM x0 AS DOUBLE, y0 AS DOUBLE
63. DIM x1 AS DOUBLE, y1 AS DOUBLE
64.  
65.  
66. SCREEN _NEWIMAGE(sw, sh, 32)
67. _SCREENMOVE 100, 20
68.  
69. 'find a place not inside a circle
70. xx = sw / 2
71. yy = sh / 2
72. WHILE checkxy%(xx, yy) = 0
73.     xx = INT(RND * (sw - 2 * maxr)) + maxr
74.     yy = INT(RND * (sh - 2 * maxr)) + maxr
75. WEND
76.  
77. DO
78.     IF LEN(INKEY$) THEN
79.         _DELAY 5 'to get dang screen shot
80.     ELSE
81.         'get mouse x, y if click
82.         DO
83.             mx = _MOUSEX
84.             my = _MOUSEY
85.             mb = _MOUSEBUTTON(1)
86.         LOOP WHILE _MOUSEINPUT
87.     END IF
88.     'cls
89.     LINE (0, 0)-(sw, sh), qb(0), BF
90.     'draw circles
91.     FOR c = 1 TO nCircs
92.         COLOR cs(c).c
93.         fcirc cs(c).x, cs(c).y, cs(c).r
94.     NEXT
95.  
96.     'if click make sure click was not inside one of the circles
97.     IF mb THEN
98.         DO WHILE mb
99.             DO
100.                 mb = _MOUSEBUTTON(1)
101.             LOOP WHILE _MOUSEINPUT
102.         LOOP
103.         f = checkxy%(mx, my)
104.         IF f THEN
105.             xx = mx
106.             yy = my
107.             f = -1
108.         END IF
109.     END IF
110.  
111.     x0 = xx
112.     y0 = yy
113.     a = _ATAN2(my - yy, mx - xx)
114.     t = 0
115.     DO
116.         t = t + 1
117.         x = t * COS(a) + x0
118.         y = t * SIN(a) + y0
119.         IF x < 0 OR x > sw OR y < 0 OR y > sh THEN EXIT DO
120.         FOR c = 1 TO nCircs
121.             IF (x - cs(c).x) ^ 2 + (y - cs(c).y) ^ 2 < cs(c).r * cs(c).r THEN
122.                 a1 = _ATAN2(y - cs(c).y, x - cs(c).x)
123.                 a2 = 2 * a1 - a - _PI
124.                 LINE (x0, y0)-(x, y), qb(14)
125.                 x0 = x
126.                 y0 = y
127.                 a = a2
128.                 t = 0
129.                 EXIT FOR
130.             END IF
131.         NEXT
132.     LOOP
133.     LINE (x0, y0)-(x, y), qb(14)
134.     _DISPLAY
135.     _LIMIT 50
136. LOOP UNTIL _KEYHIT = 27
137. SYSTEM
138.  
139. FUNCTION checkxy% (x, y)
140.     DIM c AS INTEGER
141.     FOR c = 1 TO nCircs
142.         IF (x - cs(c).x) ^ 2 + (y - cs(c).y) ^ 2 < cs(c).r * cs(c).r THEN checkxy% = 0: EXIT FUNCTION
143.     NEXT
144.     checkxy% = 1
145. END FUNCTION
146.  
147. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
148. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
149.     DIM subRadius AS LONG, RadiusError AS LONG
150.     DIM X AS LONG, Y AS LONG
151.  
152.     subRadius = ABS(R)
153.     RadiusError = -subRadius
154.     X = subRadius
155.     Y = 0
156.  
157.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
158.  
159.     ' Draw the middle span here so we don't draw it twice in the main loop,
160.     ' which would be a problem with blending turned on.
161.     LINE (CX - X, CY)-(CX + X, CY), , BF
162.  
163.     WHILE X > Y
164.         RadiusError = RadiusError + Y * 2 + 1
165.         IF RadiusError >= 0 THEN
166.             IF X <> Y + 1 THEN
167.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
168.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
169.             END IF
170.             X = X - 1
171.             RadiusError = RadiusError - X * 2
172.         END IF
173.         Y = Y + 1
174.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
175.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
176.     WEND
177. END SUB
178.  
179.  
180.  

Title: Re: Chaotic scattering
Post by: FellippeHeitor on February 15, 2018, 09:51:23 pm

Everything looks better with semitransparent cls:

Code: QB64: [Select]

1.     'cls
2.     LINE (0, 0)-(sw, sh), _RGBA32(0, 0, 0, 30), BF

Title: Re: Chaotic scattering
Post by: bplus on February 15, 2018, 09:59:31 pm

Oh yeah! Suddenly the laser light is ... I don't know how to describe it, but it is vastly improved!

So with transparent layers over the beam each frame, you can still see the ones before in the frames before fading as they get covered over more and more. Nice effect!

Title: Re: Chaotic scattering
Post by: bplus on February 15, 2018, 10:41:39 pm

Decent screen shots are hard to get (for me anyway) this is OK:

Title: Re: Chaotic scattering
Post by: _vince on February 16, 2018, 12:45:52 am

Wow nice work bplus.  Neat to see that you were able to interpret the code.  @phil yeah I wanted to post the fading one initially but I may have lost it.

Title: Re: Chaotic scattering
Post by: bplus on February 16, 2018, 10:00:18 am

It is funny, I change the SCREEN _NEWIMAGE color number to 32 for RGB full range which I am most familiar and then realize you, v, were using QB color numbers for the line, daaaaaaaaaaaah! well at least I now have my QB numbers updated in my 000Handy.bas file for code to copy and paste from, not up to library level yet.

https://www.qb64.org/wiki/NEWIMAGE

so the 12 v had was for screen 12 colors

https://www.qb64.org/wiki/SCREEN

16 color, 4 BPP

Sure glad to see Wiki!

Well not a total waste of time to switch to 32, it was easy as pie to implement Fellippe's suggestion for cls with transparencies. I bet that trick will come in handy in future!

Text Only | Text with Attachments