Author Topic: DrawWorms code test and demo  (Read 4518 times)

0 Members and 1 Guest are viewing this topic.

Offline bplus

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

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


Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: DrawWorms code test and demo
« Reply #1 on: October 07, 2021, 12:25:01 pm »
       
                  Alt + F4

If your program hangs up and escape doesn't work

Offline Petr

  • Forum Resident
  • Posts: 1720
  • The best code is the DNA of the hops.
    • View Profile
Re: DrawWorms code test and demo
« Reply #2 on: October 07, 2021, 01:44:25 pm »
Nice work :)

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: DrawWorms code test and demo
« Reply #3 on: October 07, 2021, 02:32:14 pm »
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.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: DrawWorms code test and demo
« Reply #4 on: October 07, 2021, 03:23:06 pm »
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?

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: DrawWorms code test and demo
« Reply #5 on: October 07, 2021, 03:57:57 pm »
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.  
  15.  
  16.  

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