DrawWorms code test and demo

[bplus]

This is graphics effect test and demo, I am hoping to add to Crypt-O-Gram Puzzle.

All White and Yellow colors are poison to worms, still they will nibble because where ever they go they lay down a black track on the screen.

If the program hangs just press esc, there is a problem sometimes that hangs often at start new WormYard init.

Should be fun to watch, the first test makes sure worms stay in WormYard and that White really discourages worms from proceeding further in their current direction that ran into White. ha! sometimes a white box is laid over worm and then it's trapped (but could hang program? not being able to find direction to go).

Code: QB64: [Select]

1. sc& = _ScreenImage
2. _Title "DrawWorms Test and Demo, worms should avoid Yellow and White" 'b+ 2021-10-06
3. ' This is intended for Crypt-O-Gram Puzzle but may use else where also.
4. ' This needs to be done in background on the side and updated with main loop in program using it.
5.  
6. ' Use general Object
7. Type object
8.     x As Single
9.     y As Single
10.     w As Single
11.     h As Single
12.     dx As Single
13.     dy As Single
14.     dir As Single
15.     sz As Single
16.     c As _Unsigned Long
17. End Type
18.  
19. Const nWorms = 30
20. Const xmax = 800, ymax = 600
21. Dim Shared Worms(1 To nWorms) As object
22. Dim Shared WormYard As object
23. Screen _NewImage(xmax, ymax, 32)
24. _Delay .25
25. _ScreenMove _Middle
26. Color &HFFDDDDDD, &HFF442211
27. Cls 'set backcolor
28. NewWormYard _Width / 4, _Height / 4, _Width / 2, _Height / 2 ' for this demo the middle of the screen
29. init = -1
30. Do
31.     'sample main loop action
32.     lc = lc + 1
33.     If lc Mod 200 = 199 Then init = -1: Cls
34.     Locate 1, 1: Print lc
35.     If Rnd < .5 Then c~& = _RGB32(255, 255, 255) Else c~& = _RGB32(255, 0, 0)
36.     Line (Rnd * _Width, Rnd * _Height)-Step(Rnd * 50, Rnd * 50), c~&, BF
37.     DrawWorms init
38.     _Limit 10
39. Loop Until _KeyDown(27)
40.  
41. Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
42. _Delay .25
43. '_ScreenMove _Middle
44. _FullScreen
45. _PutImage , sc&, 0
46. ' end perfect
47. _Delay .25 ' <<<< possible racing problem with change of screen size and _width adn Height update
48. NewWormYard 0, 0, _Width, _Height ' <<< update WornYard to new screen size
49. _PutImage , sc&, 0
50. init = -1 'only way to see sc& ??????????????/
51. Do
52.     DrawWorms init
53.     _Limit 10
54. Loop Until _KeyDown(27)
55.  
56. Sub DrawWorms (DrawReset) ' one frame in main loop
57.     Static x(1 To nWorms, 1 To 20), y(1 To nWorms, 1 To 20)
58.     If DrawReset Then
59.         For i = 1 To nWorms
60.             NewWorm i
61.             For j = 1 To 20
62.                 x(i, j) = 0: y(i, j) = 0
63.             Next
64.         Next
65.         DrawReset = 0
66.     End If
67.     For i = 1 To nWorms
68.         If _KeyDown(27) Then Exit Sub
69.         For j = 1 To Worms(i).sz ' blackout old segments
70.             If x(i, j) And y(i, j) Then fcirc x(i, j), y(i, j), 8, &HFF000000
71.         Next
72.         tryAgain:
73.         If _KeyDown(27) Then Exit Sub
74.         If Rnd < .3 Then Worms(i).dx = Worms(i).dx + .8 * Rnd - .4 Else Worms(i).dy = Worms(i).dy + .8 * Rnd - .4
75.         If Abs(Worms(i).dx) > 2 Then Worms(i).dx = Worms(i).dx * .5
76.         If Abs(Worms(i).dy) > 2 Then Worms(i).dy = Worms(i).dy * .5
77.         x = Worms(i).x + Worms(i).dx * 2.0: y = Worms(i).y + Worms(i).dy * 2.0
78.         good = -1
79.         If x >= WormYard.x + 6 And x <= WormYard.x + WormYard.w - 6 Then
80.             If y >= WormYard.y + 6 And y <= WormYard.y + WormYard.h - 6 Then
81.                 For yy = y - 6 To y + 6
82.                     For xx = x - 6 To x + 6
83.                         If Point(xx, yy) = _RGB32(255, 255, 255) Or Point(xx, yy) = _RGB32(255, 255, 0) Then good = 0: Exit For
84.                     Next
85.                     If good = 0 Then Exit For
86.                 Next
87.             Else
88.                 good = 0
89.             End If
90.         Else
91.             good = 0
92.         End If
93.         If good = 0 Then 'turn the worm
94.             'Beep: Locate 1, 1: Print x, y
95.             'Input "enter >", w$
96.             If Rnd > .5 Then 'change dx
97.                 If Worms(i).dx Then
98.                     Worms(i).dx = -Worms(i).dx
99.                 Else
100.                     If Rnd > .5 Then Worms(i).dx = 1 Else Worms(i).dx = -1
101.                 End If
102.             Else
103.                 If Worms(i).dy Then
104.                     Worms(i).dy = -Worms(i).dy
105.                 Else
106.                     If Rnd > .5 Then Worms(i).dy = 1 Else Worms(i).dy = -1
107.                 End If
108.             End If
109.             GoTo tryAgain
110.         End If
111.         For j = Worms(i).sz To 2 Step -1
112.             x(i, j) = x(i, j - 1): y(i, j) = y(i, j - 1)
113.             If x(i, j) And y(i, j) Then drawBall x(i, j), y(i, j), 6, Worms(i).c
114.         Next
115.         x(i, 1) = x: y(i, 1) = y
116.         drawBall x(i, 1), y(i, 1), 6, Worms(i).c
117.         Worms(i).x = x: Worms(i).y = y
118.     Next i 'worm index
119. End Sub
120.  
121. Sub NewWormYard (x, y, w, h)
122.     WormYard.x = x: WormYard.y = y: WormYard.w = w: WormYard.h = h
123.     For i = 1 To nWorms
124.         NewWorm i
125.     Next
126. End Sub
127.  
128. Sub NewWorm (i)
129.     'pick which side to enter, for dx, dy generally headed towards inner screen
130.     side = Int(Rnd * 4)
131.     Select Case side
132.         Case 0 ' left side
133.             Worms(i).x = WormYard.x + 6
134.             Worms(i).y = WormYard.y + 6 + (WormYard.h - 12) * Rnd
135.             Worms(i).dx = 1
136.             Worms(i).dy = 0
137.         Case 1 'right side
138.             Worms(i).x = WormYard.x + WormYard.w - 6
139.             Worms(i).y = WormYard.y + 6 + (WormYard.h - 12) * Rnd
140.             Worms(i).dx = -1
141.             Worms(i).dy = 0
142.         Case 2 ' top
143.             Worms(i).y = WormYard.y + 6
144.             Worms(i).x = WormYard.x + 6 + (WormYard.w - 12) * Rnd
145.             Worms(i).dx = 0
146.             Worms(i).dy = 1
147.         Case 3 'bottom
148.             Worms(i).y = WormYard.y + WormYard.h - 6
149.             Worms(i).x = WormYard.x + 6 + (WormYard.w - 12) * Rnd
150.             Worms(i).dx = 0
151.             Worms(i).dy = -1
152.     End Select
153.     Worms(i).sz = Int(Rnd * 11) + 10
154.     side = Int(Rnd * 4): lev = Int(Rnd * 10)
155.     If side = 0 Then
156.         Worms(i).c = _RGB32(255 - 20 * lev + 50, 180 - 15 * lev, 180 - 15 * lev)
157.     ElseIf side = 1 Then
158.         Worms(i).c = _RGB32(255 - 20 * lev, 180 - 15 * lev + 50, 180 - 15 * lev)
159.     ElseIf side = 2 Then
160.         Worms(i).c = _RGB32(255 - 20 * lev, 180 - 15 * lev, 180 - 15 * lev + 20)
161.     ElseIf side = 3 Then
162.         Worms(i).c = _RGB32(255 - 20 * lev, 180 - 15 * lev, 180 - 15 * lev)
163.     End If
164. End Sub
165.  
166. Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
167.     Dim Radius As Long, RadiusError As Long
168.     Dim X As Long, Y As Long
169.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
170.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
171.     Line (CX - X, CY)-(CX + X, CY), C, BF
172.     While X > Y
173.         RadiusError = RadiusError + Y * 2 + 1
174.         If RadiusError >= 0 Then
175.             If X <> Y + 1 Then
176.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
177.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
178.             End If
179.             X = X - 1
180.             RadiusError = RadiusError - X * 2
181.         End If
182.         Y = Y + 1
183.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
184.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
185.     Wend
186. End Sub
187.  
188. Sub drawBall (x, y, r, c As _Unsigned Long)
189.     Dim rred As Long, grn As Long, blu As Long, rr As Long, f
190.     rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
191.     For rr = r To 0 Step -1
192.         f = 1.25 - rr / r
193.         fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
194.     Next
195. End Sub
196.  
197.  

Oh! I should lay down a black circle for first x,y of newly init worm!

[bplus]

       
                  Alt + F4

If your program hangs up and escape doesn't work

[Petr]

Nice work :)

[bplus]

Thankyou Petr!

This line does stop the hang at lc = 599 (not Randomize Timer so I can say when it hangs and you should get same result)

Insert this at Line #68 (just after Main For loop through all worm indexes):

Code: QB64: [Select]

1.     For i = 1 To nWorms
2.         fcirc Worms(i).x, Worms(i).y, 8, &HFF000000 ' fix 2021-10-07 to prevent program hangs
3.  

Still hangs later at 865 but escape takes me onto next demo without a hang up type crash.

[bplus]

Oh! I am reminded of another issue that came up creating the DrawWorms Sub.

When I want to clear worm segment locations and start a new set of worms I set DrawReset to -1 = True
when the sub gets this signal I want to clear out the x(), y() data stored in STATIC arrays, I tried Erase but got error, maybe I did wrong? and I knew REDIM wouldn't work so as you see, I went the hard way with 2 indexes and went through and reset each element to 0.

Code: QB64: [Select]

1. SUB DrawWorms (DrawReset) ' one frame in main loop
2.     STATIC x(1 TO nWorms, 1 TO 20), y(1 TO nWorms, 1 TO 20)
3.     IF DrawReset THEN
4.         FOR i = 1 TO nWorms
5.             NewWorm i
6.             FOR j = 1 TO 20
7.                 x(i, j) = 0: y(i, j) = 0
8.             NEXT
9.         NEXT
10.         DrawReset = 0
11.     END IF
12.  

Was there an easier way to clear a STATIC array of values?

[bplus]

Looking forward to other effects I (might) want to add, I've updated my Object Type to this:

Code: QB64: [Select]

1. ' Use general Object
2. Type Object
3.     X As Single ' usu top left corner   could be center depending on object
4.     Y As Single ' ditto
5.     W As Single ' width   or maybe radius
6.     H As Single ' height
7.     DX As Single ' moving opjects
8.     DY As Single ' ditto
9.     DIR As Single ' short for direction or heading usu a radian angle
10.     Sz As Single ' perhaps a scaling factor
11.     Act As Integer ' lives countdown or just plain ACTive TF
12.     C1 As _Unsigned Long ' a foreground color
13.     C2 As _Unsigned Long ' a background or 2nd color   OR C1 to c2 Range?
14. End Type
15.  
16.  
17.  

The B+All General Object for most my purposes? I think even images could be used with this Type.

Just update code above with Type Object and change all .c's to .C1