QB64.org Forum

Active Forums => Programs => Topic started by: bplus on April 28, 2018, 10:00:58 pm

Title: Mouse school of critters
Post by: bplus on April 28, 2018, 10:00:58 pm

Practice code for Boid Watching

Code: QB64: [Select]

1. _TITLE "Mouse school of critters - Click to toggle Mouse as Predator or Prey    by bplus 2018-04-27"
2. 'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
3. 'from: Mouse school critters separated.txt for JB 2.0 B+ 2018-04-24
4. '2018-04-27 update for Predator / Prey Toggle with Click
5.  
6. CONST xmax = 1200
7. CONST ymax = 700
8. SCREEN _NEWIMAGE(xmax, ymax, 32)
9. _SCREENMOVE 100, 40
10. RANDOMIZE TIMER
11. DIM SHARED qb(15)
12. qb(0) = &HFF000000
13. qb(1) = &HFF000088
14. qb(2) = &HFF008800
15. qb(3) = &HFF008888
16. qb(4) = &HFF880000
17. qb(5) = &HFF880088
18. qb(6) = &HFF888800
19. qb(7) = &HFFCCCCCC
20. qb(8) = &HFF888888
21. qb(9) = &HFF0000FF
22. qb(10) = &HFF00FF00
23. qb(11) = &HFF00FFFF
24. qb(12) = &HFFFF0000
25. qb(13) = &HFFFF00FF
26. qb(14) = &HFFFFFF00
27. qb(15) = &HFFFFFFFF
28.  
29. na = 50
30. DIM SHARED x(na), y(na), v(na), r(na), c(na), predator
31. FOR i = 1 TO na
32.     x(i) = rand(0, xmax)
33.     y(i) = rand(0, ymax)
34.     rr = INT(RND * 15)
35.     v(i) = rr * 1
36.     r(i) = rand(10, 30)
37.     c(i) = qb(rr)
38. NEXT
39.  
40. WHILE 1
41.     CLS
42.     IF INKEY$ = "q" THEN END
43.     FOR i = 1 TO na
44.         m = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
45.         IF mb THEN
46.             WHILE mb
47.                 m = _MOUSEINPUT: mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
48.                 _LIMIT 200
49.             WEND
50.             IF predator THEN predator = 0 ELSE predator = 1
51.         END IF
52.  
53.         'radian angle to mouse
54.         ra = _ATAN2(my - y(i), mx - x(i)) '  + pi kind of interesting too
55.         'draw it
56.         critter i, ra
57.  
58.         'separate critters for next frame and further down i line
59.         FOR j = i + 1 TO na
60.  
61.             ' The following is STATIC's adjustment of ball positions if overlapping
62.             ' before calcultion of new positions from collision
63.             ' Displacement vector and its magnitude.  Thanks STxAxTIC !
64.             nx = x(j) - x(i)
65.             ny = y(j) - y(i)
66.             nm = SQR(nx ^ 2 + ny ^ 2)
67.             IF nm < 10 + r(i) + r(j) THEN
68.                 nx = nx / nm
69.                 ny = ny / nm
70.  
71.                 ' Regardless of momentum exchange, separate the balls along the lone connecting them.
72.                 WHILE nm < 10 + r(i) + r(j)
73.  
74.                     flub = 10 '  massively increased for JB to speed up code
75.  
76.                     x(j) = x(j) + flub * nx
77.                     y(j) = y(j) + flub * ny
78.  
79.                     x(i) = x(i) - flub * nx
80.                     y(i) = y(i) - flub * ny
81.  
82.                     nx = x(j) - x(i)
83.                     ny = y(j) - y(i)
84.                     nm = SQR(nx ^ 2 + ny ^ 2)
85.                     nx = nx / nm
86.                     ny = ny / nm
87.                 WEND
88.             END IF
89.         NEXT
90.         IF predator THEN
91.             x(i) = x(i) + v(i) * COS(ra + _PI)
92.             y(i) = y(i) + v(i) * SIN(ra + _PI)
93.         ELSE
94.             x(i) = x(i) + v(i) * COS(ra)
95.             y(i) = y(i) + v(i) * SIN(ra)
96.         END IF
97.     NEXT
98.     _DISPLAY
99.     _LIMIT 20
100. WEND
101.  
102. SUB critter (i, ra)
103.     COLOR c(i)
104.     fcirc x(i), y(i), r(i)
105.     IF predator THEN
106.         x1 = x(i) + .75 * r(i) * COS(ra - _PI(1 / 9) + _PI)
107.         y1 = y(i) + .75 * r(i) * SIN(ra - _PI(1 / 9) + _PI)
108.         x2 = x(i) + .75 * r(i) * COS(ra + _PI(1 / 9) + _PI)
109.         y2 = y(i) + .75 * r(i) * SIN(ra + _PI(1 / 9) + _PI)
110.     ELSE
111.         x1 = x(i) + .75 * r(i) * COS(ra - _PI(1 / 9))
112.         y1 = y(i) + .75 * r(i) * SIN(ra - _PI(1 / 9))
113.         x2 = x(i) + .75 * r(i) * COS(ra + _PI(1 / 9))
114.         y2 = y(i) + .75 * r(i) * SIN(ra + _PI(1 / 9))
115.     END IF
116.     COLOR qb(15)
117.     fcirc x1, y1, .25 * r(i)
118.     fcirc x2, y2, .25 * r(i)
119.     IF predator THEN
120.         x3 = x1 + .125 * r(i) * COS(ra + _PI)
121.         y3 = y1 + .125 * r(i) * SIN(ra + _PI)
122.         x4 = x2 + .125 * r(i) * COS(ra + _PI)
123.         y4 = y2 + .125 * r(i) * SIN(ra + _PI)
124.     ELSE
125.         x3 = x1 + .125 * r(i) * COS(ra)
126.         y3 = y1 + .125 * r(i) * SIN(ra)
127.         x4 = x2 + .125 * r(i) * COS(ra)
128.         y4 = y2 + .125 * r(i) * SIN(ra)
129.     END IF
130.     COLOR qb(0)
131.     fcirc x3, y3, .125 * r(i)
132.     fcirc x4, y4, .125 * r(i)
133. END SUB
134.  
135. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
136. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
137.     DIM subRadius AS LONG, RadiusError AS LONG
138.     DIM X AS LONG, Y AS LONG
139.  
140.     subRadius = ABS(R)
141.     RadiusError = -subRadius
142.     X = subRadius
143.     Y = 0
144.  
145.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
146.  
147.     ' Draw the middle span here so we don't draw it twice in the main loop,
148.     ' which would be a problem with blending turned on.
149.     LINE (CX - X, CY)-(CX + X, CY), , BF
150.  
151.     WHILE X > Y
152.         RadiusError = RadiusError + Y * 2 + 1
153.         IF RadiusError >= 0 THEN
154.             IF X <> Y + 1 THEN
155.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
156.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
157.             END IF
158.             X = X - 1
159.             RadiusError = RadiusError - X * 2
160.         END IF
161.         Y = Y + 1
162.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
163.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
164.     WEND
165. END SUB
166.  
167. FUNCTION rand% (lo%, hi%)
168.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
169. END FUNCTION
170.  
171.  

Text Only | Text with Attachments