QB64.org Forum

Active Forums => Programs => Topic started by: bplus on September 15, 2020, 08:09:37 pm

Title: Meander testing grounds
Post by: bplus on September 15, 2020, 08:09:37 pm
Problem is first discussed here between Cobalt and I:
https://www.qb64.org/forum/index.php?topic=3018.msg122803#msg122803

Here is first rough draft prototype for meandering:
Code: QB64: [Select]
  1. _TITLE "Meander ProtoType for Cobolt Problem" ' b+ 2020-09-15
  2. SCREEN _NEWIMAGE(800, 600, 32)
  3. _DELAY .25
  4. DIM SHARED distx, disty, endx, endy, x, y
  5.  
  6. startx = 10: starty = 10: endx = 790: endy = 590
  7.     x = startx: y = starty
  8.     dist
  9.     time = INT(RND * 16 + 4) ' total amoount allowed to move  The More the time the more the meander!!!!
  10.     meanderTime = time '       > 20 is too much!!
  11.     _PRINTSTRING (10, _HEIGHT - 20), " Meander:" + STR$(meanderTime)
  12.     LINE (startx, starty)-STEP(4, 4), &HFFFF000, BF
  13.     LINE (endx, endy)-STEP(4, 4), &HFF0000FF, BF
  14.     IF RND < .5 THEN lastmoveX = 0 ELSE lastmoveX = -1
  15.     lastx = startx
  16.     lasty = starty
  17.     DO
  18.         dist
  19.         IF RND < .5 THEN d = -1 ELSE d = 1
  20.         IF lastmoveX = 0 THEN
  21.             lastx = x
  22.             IF time <= 3 THEN
  23.                 x = endx
  24.             ELSE
  25.                 dx = d * (.4 * distx + 5)
  26.                 IF x + dx > 0 AND x + dx < _WIDTH THEN
  27.                     x = x + dx
  28.                 ELSE
  29.                     x = x + -dx
  30.                 END IF
  31.             END IF
  32.             LINE (lastx, y)-(x, y)
  33.             lastmoveX = -1
  34.         ELSE
  35.             lasty = y
  36.             IF time <= 3 THEN
  37.                 y = endy
  38.             ELSE
  39.                 dy = d * (.3 * disty + 5)
  40.                 IF y + dy > 0 AND y + dy < _HEIGHT THEN
  41.                     y = y + dy
  42.                 ELSE
  43.                     y = y + -dy
  44.                 END IF
  45.             END IF
  46.             LINE (x, lasty)-(x, y)
  47.             lastmoveX = 0
  48.         END IF
  49.         time = time - 1
  50.         _LIMIT 10
  51.     LOOP UNTIL time <= 0 OR _KEYDOWN(27)
  52.     CLS
  53.  
  54. SUB dist
  55.     distx = endx - x: disty = endy - y
  56.  
  57.  

We could get fancy and limit the number of path crossovers to 1 or 2? if doesn't block path to target.
Title: Re: Meander testing grounds
Post by: bplus on September 15, 2020, 11:15:13 pm
Code: QB64: [Select]
  1. _TITLE "Meander #2 the SUB" ' b+ 2020-09-15
  2. SCREEN _NEWIMAGE(1200, 720, 32)
  3. _DELAY .25
  4. DIM SHARED distx, disty, endx, endy, x, y
  5.  
  6. nboxes = 20
  7.     COLOR &HFF000000, &HFF882200: CLS
  8.     REDIM xx(nboxes), yy(nboxes)
  9.     x = RND * _WIDTH: y = RND * _HEIGHT: w = RND * .1 * _WIDTH + 36: h = RND * .1 * _HEIGHT + 21
  10.     LINE (x - .5 * w, y - .5 * h)-STEP(w, h), , BF ' _RGB32(RND * 200 + 55, RND * 200 + 55, RND * 200 + 55), BF
  11.     xx(1) = x: yy(1) = y: b = 1
  12.     FOR i = 2 TO nboxes
  13.         tryAgain:
  14.         x2 = RND * _WIDTH: y2 = RND * _HEIGHT: OK = -1
  15.         FOR j = 1 TO i - 1
  16.             IF _HYPOT(xx(j) - x2, yy(j) - y2) < 150 THEN OK = 0: EXIT FOR
  17.         NEXT
  18.         IF OK = 0 THEN GOTO tryAgain
  19.         xx(i) = x2: yy(i) = y2
  20.         w2 = RND * .1 * _WIDTH + 36: h2 = RND * .1 * _HEIGHT + 21
  21.         LINE (x2 - .5 * w2, y2 - .5 * h2)-STEP(w2, h2), , BF '_RGB32(RND * 200 + 55, RND * 200 + 55, RND * 200 + 55), BF
  22.         meander x, y, x2, y2
  23.         x = x2: y = y2: w = w2: h = h2
  24.     NEXT
  25.     _DELAY 2
  26.     CLS
  27.  
  28. SUB meander (x1, y1, x2, y2)
  29.     startx = x1: starty = y1: endx = x2: endy = y2
  30.     x = startx: y = starty
  31.     GOSUB dist
  32.     IF distx + disty > 140 THEN
  33.         time = INT(RND * 6 + 4) ' total amount allowed to move  The More the time the more the meander!!!!
  34.     ELSE
  35.         time = 3
  36.     END IF
  37.     meanderTime = time '       > 20 is too much!!
  38.     IF RND < .5 THEN lastmoveX = 0 ELSE lastmoveX = -1
  39.     lastx = startx: lasty = starty
  40.     DO
  41.         GOSUB dist
  42.         IF RND < .5 THEN d = -1 ELSE d = 1
  43.         IF lastmoveX = 0 THEN
  44.             lastx = x
  45.             IF time <= 3 THEN
  46.                 x = endx
  47.             ELSE
  48.                 dx = d * (.4 * distx + 100)
  49.                 IF x + dx > 0 AND x + dx < _WIDTH THEN
  50.                     x = x + dx
  51.                 ELSE
  52.                     x = x + -dx
  53.                 END IF
  54.             END IF
  55.             'LINE (lastx, y)-(x, y)
  56.             beeline lastx, y, x, y
  57.             lastmoveX = -1
  58.         ELSE
  59.             lasty = y
  60.             IF time <= 3 THEN
  61.                 y = endy
  62.             ELSE
  63.                 dy = d * (.3 * disty + 100)
  64.                 IF y + dy > 0 AND y + dy < _HEIGHT THEN
  65.                     y = y + dy
  66.                 ELSE
  67.                     y = y + -dy
  68.                 END IF
  69.             END IF
  70.             'LINE (x, lasty)-(x, y)
  71.             beeline x, lasty, x, y
  72.             lastmoveX = 0
  73.         END IF
  74.         time = time - 1
  75.         _LIMIT 10
  76.     LOOP UNTIL time <= 0 OR _KEYDOWN(27)
  77.     EXIT SUB
  78.     dist:
  79.     distx = endx - x: disty = endy - y
  80.     RETURN
  81.  
  82. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  83.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  84.     DIM X AS INTEGER, Y AS INTEGER
  85.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
  86.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  87.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  88.     WHILE X > Y
  89.         RadiusError = RadiusError + Y * 2 + 1
  90.         IF RadiusError >= 0 THEN
  91.             IF X <> Y + 1 THEN
  92.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  93.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  94.             END IF
  95.             X = X - 1
  96.             RadiusError = RadiusError - X * 2
  97.         END IF
  98.         Y = Y + 1
  99.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  100.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  101.     WEND
  102.  
  103. SUB beeline (x1, y1, x2, y2)
  104.     IF x1 = x2 THEN
  105.         IF y1 <= y2 THEN FOR y = y1 TO y2: fcirc x1, y, 4, &HFF000000: NEXT
  106.         IF y1 > y2 THEN FOR y = y1 TO y2 STEP -1: fcirc x1, y, 4, &HFF000000: NEXT
  107.     ELSE
  108.         IF x1 <= x2 THEN FOR x = x1 TO x2: fcirc x, y1, 4, &HFF000000: NEXT
  109.         IF x1 > x2 THEN FOR x = x1 TO x2 STEP -1: fcirc x, y1, 4, &HFF000000: NEXT
  110.     END IF
Title: Re: Meander testing grounds
Post by: Cobalt on September 16, 2020, 01:32:17 am
when I try your 1st post code, B+, I get the following:
In file included from qbx.cpp:2208:
..\\temp\\main.txt:208:1: error: 'LABEL_5' does not name a type; did you mean 'HACCEL__'?
 LABEL_5:;
 ^~~~~~~
 HACCEL__
compilation terminated due to -Wfatal-errors.

I'll try the second...
Title: Re: Meander testing grounds
Post by: Cobalt on September 16, 2020, 01:40:06 am
Okay the second one works.

does TIME change how much meandering the tunneler does between rooms?

looks pretty good, though it is okay if some rooms are not fully connected, not sure what I would have to change to allow that to happen.
Title: Re: Meander testing grounds
Post by: bplus on September 16, 2020, 07:38:07 am
when I try your 1st post code, B+, I get the following:
In file included from qbx.cpp:2208:
..\\temp\\main.txt:208:1: error: 'LABEL_5' does not name a type; did you mean 'HACCEL__'?
 LABEL_5:;
 ^~~~~~~
 HACCEL__
compilation terminated due to -Wfatal-errors.

I'll try the second...

What is line 5?, HACCEL__? and no way is there 208 lines in main text! WTH are feeding QB64?

Are you using vers 1.4 on Windows system? Windows 10? and my bas file?

It's funny, the 2nd is much more complicated with beelines and the room spacing ;-)
Title: Re: Meander testing grounds
Post by: bplus on September 16, 2020, 07:41:59 am
Okay the second one works.

does TIME change how much meandering the tunneler does between rooms?

looks pretty good, though it is okay if some rooms are not fully connected, not sure what I would have to change to allow that to happen.

The rooms are fully connected because it is designed to makeup a room at a certain distance from all others, start at that room and "meander" to the next made up room. Some meandering takes place inside other rooms. And yes! most definitely the longer the time the more the meandering, I even said that in a comment.

Meander itself will only go from point A to point B (eventually) regardless of what else is in the way.
You only have to tell meander which 2 points to connect (eventually). You might want to take beeLine out of meander and use your own methods of drawing the path (the LINE statements are still in there commented out).
Title: Re: Meander testing grounds
Post by: Cobalt on September 16, 2020, 10:24:59 am
What is line 5?, HACCEL__? and no way is there 208 lines in main text! WTH are feeding QB64?

Are you using vers 1.4 on Windows system? Windows 10? and my bas file?

It's funny, the 2nd is much more complicated with beelines and the room spacing ;-)

Looking at the translated code it is indeed 208 lines. All that error checking!

But when I tried it this morning all seems good. Something must have been corupted somewhere on my machine last night.

I was working a lot with MEM functions so perhaps I upset something?

The rooms are fully connected because it is designed to makeup a room at a certain distance from all others, start at that room and "meander" to the next made up room. Some meandering takes place inside other rooms. And yes! most definitely the longer the time the more the meandering, I even said that in a comment.

Meander itself will only go from point A to point B (eventually) regardless of what else is in the way.
You only have to tell meander which 2 points to connect (eventually). You might want to take beeLine out of meander and use your own methods of drawing the path (the LINE statements are still in there commented out).

Yeah I have been trying to piece together how to adjust this to work in an array(194,79) but the output looks fairly nice. A lot better than I was getting.

every so often the output is spot on. The only thing might be to give it some 'influence' to meander toward the target room so when it beelines its not so abrupt and straight lined for so long.

But like I said this looks so much better than what I was getting.
Title: Re: Meander testing grounds
Post by: bplus on September 16, 2020, 10:33:00 am
Quote
every so often the output is spot on. The only thing might be to give it some 'influence' to meander toward the target room so when it beelines its not so abrupt and straight lined for so long.

The dx, (& dy) lines:
Code: QB64: [Select]
  1. dx = d * (.4 * distx + 100)
  2.  

Drop or fiddle with 100 number. If you eliminate completely you could get a number of tiny x the y moves.

I used 100 to get dramatic minimum distance  to move = dx, dy to avoid a RND walk in a 10 pixel radial area.
Title: Re: Meander testing grounds
Post by: FellippeHeitor on September 16, 2020, 10:48:27 am
when I try your 1st post code, B+, I get the following:
In file included from qbx.cpp:2208:
..\\temp\\main.txt:208:1: error: 'LABEL_5' does not name a type; did you mean 'HACCEL__'?
 LABEL_5:;
 ^~~~~~~
 HACCEL__
compilation terminated due to -Wfatal-errors.

I'll try the second...

All this looks like is Cobalt's finger went to F5 but instead hit a stray '5' after a SUB and generated this error. No labels can occur after SUB/FUNCTION blocks.

So here's how I imagine it:
- Cobalt copies the code from the codebox in the forum.
- He pastes it in the IDE - cursor is now at the end of pasted code, which means it's after the last END SUB
- Cobalt tries to run with F5 - which happens to be just above key 5. Finger slips and hits 5 just before F5.
- A stray 5 label - which gets converted in the C++ code to LABEL_5:; gets added.
- Labels after SUB/FUNCTION blocks are not allowed.
- The c++ compiler tries to find something in the C++ language that kinda resembles LABEL_5:; - compiler's auto-correct at play.
- Then you get the odd error above.

Elementary, Watson.
Title: Re: Meander testing grounds
Post by: Cobalt on September 16, 2020, 11:03:29 am
All this looks like is Cobalt's finger went to F5 but instead hit a stray '5' after a SUB and generated this error. No labels can occur after SUB/FUNCTION blocks.

So here's how I imagine it:
- Cobalt copies the code from the codebox in the forum.
- He pastes it in the IDE - cursor is now at the end of pasted code, which means it's after the last END SUB
- Cobalt tries to run with F5 - which happens to be just above key 5. Finger slips and hits 5 just before F5.
- A stray 5 label - which gets converted in the C++ code to LABEL_5:; gets added.
- Labels after SUB/FUNCTION blocks are not allowed.
- The c++ compiler tries to find something in the C++ language that kinda resembles LABEL_5:; - compiler's auto-correct at play.
- Then you get the odd error above.

Elementary, Watson.

That is possible. the layout on this laptop has the F5 directly above the 5 key. So I could have actually hit both keys at once and it took the 5 before the F5. although I am getting odd errors consistently lately. usually after working with MEM functions. Just posted the latest to Discord. Something Tells me I am misusing MEM or have found a hole somewhere.
Title: Re: Meander testing grounds
Post by: FellippeHeitor on September 16, 2020, 11:28:30 am
People more knowledgeable of how memory is handled by modern OSes may shed brighter light, but I believe your program will be terminated before it can access memory areas outside of what is allowed for it. I won't advocate for Windows though.
Title: Re: Meander testing grounds
Post by: bplus on September 16, 2020, 11:34:43 am
All this looks like is Cobalt's finger went to F5 but instead hit a stray '5' after a SUB and generated this error. No labels can occur after SUB/FUNCTION blocks.

So here's how I imagine it:
- Cobalt copies the code from the codebox in the forum.
- He pastes it in the IDE - cursor is now at the end of pasted code, which means it's after the last END SUB
- Cobalt tries to run with F5 - which happens to be just above key 5. Finger slips and hits 5 just before F5.
- A stray 5 label - which gets converted in the C++ code to LABEL_5:; gets added.
- Labels after SUB/FUNCTION blocks are not allowed.
- The c++ compiler tries to find something in the C++ language that kinda resembles LABEL_5:; - compiler's auto-correct at play.
- Then you get the odd error above.

Elementary, Watson.

Nice work Sherlock! :)
Title: Re: Meander testing grounds
Post by: bplus on September 16, 2020, 06:42:37 pm
Welcome to the Museum of Meandering Art by bplus:
Code: QB64: [Select]
  1. _TITLE "Meander #3 Mod dx dy" ' b+ 2020-09-16   so much better in living color!!
  2. SCREEN _NEWIMAGE(1200, 720, 32)
  3. _DELAY .25
  4. TYPE box
  5.     x AS SINGLE
  6.     y AS SINGLE
  7.     w AS SINGLE
  8.     h AS SINGLE
  9.     K AS _UNSIGNED LONG
  10.  
  11.     'whole new set
  12.     nBoxes = INT(RND * 11) + 10
  13.     REDIM b(1 TO nBoxes) AS box 'new box set
  14.     FOR i = 1 TO nBoxes
  15.         tryAgain:
  16.         b(i).x = RND * (_WIDTH - 70) + 35 'get x, y off the edges of screen!
  17.         b(i).y = RND * (_HEIGHT - 70) + 35
  18.         IF i > 1 THEN
  19.             OK = -1
  20.             FOR j = 1 TO i - 1
  21.                 IF _HYPOT(b(j).x - b(i).x, b(j).y - b(i).y) < 150 THEN OK = 0: EXIT FOR
  22.             NEXT
  23.             IF OK = 0 THEN GOTO tryAgain
  24.         END IF
  25.         b(i).w = 50 + RND * 50
  26.         b(i).h = 40 + RND * 45
  27.         b(i).K = _RGB32(RND * 85 + 170, RND * 85 + 170, RND * 85 + 170)
  28.     NEXT
  29.     backColor = _RGB32(RND * 85, RND * 85, RND * 85)
  30.     hc = maxC(backColor)
  31.     IF hc = 1 THEN beeLineK = _RGB32(0, RND * 170, RND * 170)
  32.     IF hc = 2 THEN beeLineK = _RGB32(RND * 170, 0, RND * 170)
  33.     IF hc = 3 THEN beeLineK = _RGB32(RND * 170, RND * 170, 0)
  34.     COLOR , backColor
  35.     CLS
  36.     FOR i = 2 TO nBoxes '                                  draw the meanderings
  37.         meander b(i - 1).x, b(i - 1).y, b(i).x, b(i).y
  38.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  39.         LINE (b(i - 1).x - b(i - 1).w * .5, b(i - 1).y - b(i - 1).h * .5)-STEP(b(i - 1).w, b(i - 1).h), b(i - 1).K, BF 'draw the boxes
  40.     NEXT
  41.     FOR i = 1 TO nBoxes
  42.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  43.     NEXT
  44.     _DISPLAY
  45.     _DELAY 5
  46.  
  47. SUB meander (x1, y1, x2, y2)
  48.     startx = x1: starty = y1: endx = x2: endy = y2: minStep = 30
  49.     x = startx: y = starty
  50.     GOSUB dist
  51.     IF dist < 200 THEN
  52.         time = INT(RND * 4 + 4) ' total amount allowed to move  The More the time the more the meander!!!!
  53.     ELSE
  54.         time = 2
  55.     END IF
  56.     startTime = time '       > 20 is too much!!
  57.     IF RND < .5 THEN lastmoveX = 0 ELSE lastmoveX = -1
  58.     lastx = startx: lasty = starty
  59.     DO
  60.         GOSUB dist
  61.         IF RND < .5 THEN d = -1 ELSE d = 1
  62.         IF lastmoveX = 0 THEN
  63.             lastx = x
  64.             IF time <= 2 THEN
  65.                 x = endx
  66.             ELSE
  67.                 dx = INT(d * (.4 * distx * RND + minStep) * minStep) / minStep
  68.                 IF dx = 0 THEN dx = minStep
  69.                 IF x + dx > 0 AND x + dx < _WIDTH THEN
  70.                     x = x + dx
  71.                 ELSE
  72.                     x = x + -dx
  73.                 END IF
  74.             END IF
  75.             x = INT(x * minStep) / minStep
  76.             'LINE (lastx, y)-(x, y)
  77.             beeline lastx, y, x, y
  78.             lastmoveX = -1
  79.         ELSE
  80.             lasty = y
  81.             IF time <= 2 THEN
  82.                 y = endy
  83.             ELSE
  84.                 dy = INT(d * (.3 * disty * RND + minStep) * minStep) / minStep
  85.                 IF dy = 0 THEN dy = minStep
  86.                 IF y + dy > 0 AND y + dy < _HEIGHT THEN
  87.                     y = y + dy
  88.                 ELSE
  89.                     y = y + -dy
  90.                 END IF
  91.             END IF
  92.             y = INT(y * minStep) / minStep
  93.             'LINE (x, lasty)-(x, y)
  94.             beeline x, lasty, x, y
  95.             lastmoveX = 0
  96.         END IF
  97.         time = time - 1
  98.         '_LIMIT 10
  99.     LOOP UNTIL time <= 0 OR _KEYDOWN(27)
  100.     EXIT SUB
  101.     dist:
  102.     distx = endx - x: disty = endy - y
  103.     RETURN
  104.  
  105. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  106.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  107.     DIM X AS INTEGER, Y AS INTEGER
  108.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
  109.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  110.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  111.     WHILE X > Y
  112.         RadiusError = RadiusError + Y * 2 + 1
  113.         IF RadiusError >= 0 THEN
  114.             IF X <> Y + 1 THEN
  115.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  116.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  117.             END IF
  118.             X = X - 1
  119.             RadiusError = RadiusError - X * 2
  120.         END IF
  121.         Y = Y + 1
  122.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  123.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  124.     WEND
  125.  
  126. SUB beeline (x1, y1, x2, y2)
  127.     IF x1 = x2 THEN
  128.         IF y1 <= y2 THEN FOR y = y1 TO y2: fcirc x1, y, 4, beeLineK: NEXT
  129.         IF y1 > y2 THEN FOR y = y1 TO y2 STEP -1: fcirc x1, y, 4, beeLineK: NEXT
  130.     ELSE
  131.         IF x1 <= x2 THEN FOR x = x1 TO x2: fcirc x, y1, 4, beeLineK: NEXT
  132.         IF x1 > x2 THEN FOR x = x1 TO x2 STEP -1: fcirc x, y1, 4, beeLineK: NEXT
  133.     END IF
  134.  
  135.     IF _RED32(K) >= _GREEN32(K) AND _RED32(K) >= _BLUE32(K) THEN maxC = 1: EXIT FUNCTION
  136.     IF _GREEN32(K) >= _BLUE(K) THEN maxC = 2 ELSE maxC = 3
  137.  
  138.  

EDIT: trying to get more contrast between background and "wiring" to rectangular lights.

hmm... if Q key or escape fail there is always alt+ F4
Title: Re: Meander testing grounds
Post by: bplus on September 17, 2020, 12:34:30 pm
Here is what I was wanting to get yesterday, Snap to Grid! and the escape and Q key presses are responding better now:
Code: QB64: [Select]
  1. _TITLE "Snapping to a Grid, press any for next grid" ' b+ 2020-09-17   so much better in living color!!
  2. ' ah much better response on on escape or Q to quit! too.
  3.  
  4. SCREEN _NEWIMAGE(1024, 620, 32)
  5. _DELAY .25
  6. '_SCREENMOVE _MIDDLE
  7.  
  8. TYPE box
  9.     x AS SINGLE
  10.     y AS SINGLE
  11.     w AS SINGLE
  12.     h AS SINGLE
  13.     K AS _UNSIGNED LONG
  14. DIM SHARED beeLineK AS _UNSIGNED LONG, gSize AS INTEGER
  15.  
  16. 'test drawGrid
  17. 'drawGrid 0, 0, _WIDTH - 1, _HEIGHT - 1, 50, &HFFFFFF00 'crap don't forget screen width and height start at 0
  18. 'LINE (0 + 1, 0 + 1)-(_WIDTH - 1, _HEIGHT - 1), &HFF0000FF, B
  19. 'SLEEP
  20. 'DO
  21. '    CLS
  22. '    x1 = RND * (_WIDTH - 200): y1 = RND * (_HEIGHT - 200)
  23. '    x2 = x1 + (_WIDTH - 1 - x1) * RND: y2 = y1 + RND * (_HEIGHT - 1 - y1)
  24. '    LINE (x1 + 1, y1 + 1)-(x2 - 1, y2 - 1), &HFF0000FF, B
  25. '    PRINT x1, y1, x2, y2
  26. '    drawGrid x1, y1, x2, y2, 50, &HFFFFFF00
  27. '    SLEEP
  28. 'LOOP
  29. 'END
  30.  
  31. DIM backColor AS _UNSIGNED LONG, hc AS INTEGER
  32.     'whole new set
  33.     gSize = units(INT(40 * RND) + 11, 5)
  34.     nBoxes = INT(SQR(_WIDTH * _HEIGHT) / gSize * RND) + 1
  35.     IF nBoxes < 15 THEN nBoxes = 15
  36.     IF nBoxes > 100 THEN nBoxes = 100
  37.     COLOR &HFFFFFFFF, &HFF000000
  38.     PRINT gSize, nBoxes
  39.     _DISPLAY
  40.     REDIM b(1 TO nBoxes) AS box 'new box set
  41.     FOR i = 1 TO nBoxes
  42.         tryAgain:
  43.         b(i).x = units(RND * (_WIDTH - 2 * (gSize + 1)) + gSize + 1, gSize) 'get x, y off the edges of screen!
  44.         b(i).y = units(RND * (_HEIGHT - 2 * (gSize + 1)) + gSize + 1, gSize)
  45.         IF i > 1 THEN
  46.             OK = -1
  47.             FOR j = 1 TO i - 1
  48.                 IF _HYPOT(b(j).x - b(i).x, b(j).y - b(i).y) < 3 * gSize THEN OK = 0: EXIT FOR
  49.             NEXT
  50.             IF OK = 0 THEN GOTO tryAgain
  51.         END IF
  52.         b(i).w = gSize + RND * gSize * .5
  53.         b(i).h = gSize + RND * gSize * .5
  54.         b(i).K = _RGB32(RND * 85 + 170, RND * 85 + 170, RND * 85 + 170)
  55.     NEXT
  56.     backColor = _RGB32(RND * 65, RND * 65, RND * 65)
  57.     hc = maxC(backColor)
  58.     IF hc = 1 THEN beeLineK = _RGB32(0, RND * 85 + 85, RND * 85 + 85)
  59.     IF hc = 2 THEN beeLineK = _RGB32(RND * 85 + 85, 0, RND * 85 + 85)
  60.     IF hc = 3 THEN beeLineK = _RGB32(RND * 85 + 85, RND * 85 + 85, 0)
  61.     COLOR , backColor
  62.     CLS
  63.     drawGrid gSize, gSize, _WIDTH - 1, _HEIGHT - 1, gSize, &HFF404040
  64.     'SLEEP
  65.     FOR i = 2 TO nBoxes '                                  draw the meanderings
  66.         meander2 b(i - 1).x, b(i - 1).y, b(i).x, b(i).y
  67.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  68.         LINE (b(i - 1).x - b(i - 1).w * .5, b(i - 1).y - b(i - 1).h * .5)-STEP(b(i - 1).w, b(i - 1).h), b(i - 1).K, BF 'draw the boxes
  69.     NEXT
  70.     FOR i = 1 TO nBoxes
  71.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  72.     NEXT
  73.     COLOR &HFFFFFFFF, background
  74.     PRINT "Press any for next screen, escape or q to quit..."
  75.     _DISPLAY
  76.     SLEEP
  77.  
  78. SUB meander2 (x1, y1, x2, y2) ' snap to grid!   gSize is shared
  79.     startx = x1: starty = y1: endx = x2: endy = y2
  80.     x = startx: y = starty
  81.     GOSUB dist
  82.     IF dist > 100 THEN
  83.         time = INT(RND * 8 + 4) ' total amount allowed to move  The More the time the more the meander!!!!
  84.     ELSE
  85.         time = 3
  86.     END IF
  87.     startTime = time '       > 20 is too much!!
  88.     IF RND < .5 THEN lastmoveX = 0 ELSE lastmoveX = -1
  89.     lastx = startx: lasty = starty
  90.     DO
  91.         GOSUB dist
  92.         IF RND < .5 THEN d = -1 ELSE d = 1
  93.         IF lastmoveX = 0 THEN
  94.             lastx = x
  95.             IF time <= 2 THEN
  96.                 x = endx
  97.             ELSE
  98.                 dx = units(d * (.4 * distx * RND + gSize), gSize)
  99.                 IF dx = 0 THEN dx = gSize
  100.                 IF x + dx > 0 AND x + dx < _WIDTH THEN
  101.                     x = x + dx
  102.                 ELSE
  103.                     x = x + -dx
  104.                 END IF
  105.             END IF
  106.             'LINE (lastx, y)-(x, y)
  107.             beeline lastx, y, x, y
  108.             lastmoveX = -1
  109.         ELSE
  110.             lasty = y
  111.             IF time <= 2 THEN
  112.                 y = endy
  113.             ELSE
  114.                 dy = units(d * (.3 * disty * RND + gSize), gSize)
  115.                 IF dy = 0 THEN dy = gSize
  116.                 IF y + dy > 0 AND y + dy < _HEIGHT THEN
  117.                     y = y + dy
  118.                 ELSE
  119.                     y = y + -dy
  120.                 END IF
  121.             END IF
  122.             'LINE (x, lasty)-(x, y)
  123.             beeline x, lasty, x, y
  124.             lastmoveX = 0
  125.         END IF
  126.         time = time - 1
  127.         '_LIMIT 10
  128.     LOOP UNTIL time <= 0
  129.     EXIT SUB
  130.     dist:
  131.     distx = endx - x: disty = endy - y
  132.     RETURN
  133.  
  134. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  135.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  136.     DIM X AS INTEGER, Y AS INTEGER
  137.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
  138.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  139.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  140.     WHILE X > Y
  141.         RadiusError = RadiusError + Y * 2 + 1
  142.         IF RadiusError >= 0 THEN
  143.             IF X <> Y + 1 THEN
  144.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  145.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  146.             END IF
  147.             X = X - 1
  148.             RadiusError = RadiusError - X * 2
  149.         END IF
  150.         Y = Y + 1
  151.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  152.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  153.     WEND
  154.  
  155. SUB beeline (x1, y1, x2, y2)
  156.     IF x1 = x2 THEN
  157.         IF y1 <= y2 THEN FOR y = y1 TO y2: fcirc x1, y, 2, beeLineK: NEXT
  158.         IF y1 > y2 THEN FOR y = y1 TO y2 STEP -1: fcirc x1, y, 2, beeLineK: NEXT
  159.     ELSE
  160.         IF x1 <= x2 THEN FOR x = x1 TO x2: fcirc x, y1, 2, beeLineK: NEXT
  161.         IF x1 > x2 THEN FOR x = x1 TO x2 STEP -1: fcirc x, y1, 2, beeLineK: NEXT
  162.     END IF
  163.  
  164.     IF _RED32(K) >= _GREEN32(K) AND _RED32(K) >= _BLUE32(K) THEN maxC = 1: EXIT FUNCTION
  165.     IF _GREEN32(K) >= _BLUE(K) THEN maxC = 2 ELSE maxC = 3
  166.  
  167. ' this sub needs FUNCTION units (x, unit)
  168. SUB drawGrid (x1, y1, x2, y2, gsize, gridClr AS _UNSIGNED LONG) ' grid of square gsize X gsize
  169.     ' fit a grid between x1, x2 and  y1, y2
  170.     ' x1, y1 top right corner and x2, y2 expected bottom right corner of boundary line
  171.  
  172.     DIM x AS INTEGER, y AS INTEGER, gx1 AS INTEGER, gy1 AS INTEGER, gx2 AS INTEGER, gy2 AS INTEGER
  173.     gx1 = units(x1, gsize): gy1 = units(y1, gsize) 'convert to grid coordinates
  174.     gx2 = units(x2, gsize): gy2 = units(y2, gsize)
  175.     IF gx1 < x1 THEN gx1 = gx1 + gsize 'stay inside boundarys passed to sub
  176.     IF gy1 < y1 THEN gy1 = gy1 + gsize
  177.     IF gx1 >= gx2 OR gy1 >= gy2 THEN EXIT SUB 'that's not even a single square!
  178.     FOR x = gx1 TO gx2 STEP gsize: LINE (x, gy1)-(x, gy2), gridClr: NEXT
  179.     FOR y = gy1 TO gy2 STEP gsize: LINE (gx1, y)-(gx2, y), gridClr: NEXT
  180.  
  181. FUNCTION units (x, unit)
  182.     units = INT(x / unit) * unit
  183.  
  184.  
  185.  

  [ This attachment cannot be displayed inline in 'Print Page' view ]  
Title: Re: Meander testing grounds
Post by: Cobalt on September 17, 2020, 02:22:01 pm
I have created a monster....

Seriously though, Thanks for the help. gets me a lot closer to the look and feel I wanted.
Title: Re: Meander testing grounds
Post by: bplus on September 17, 2020, 02:37:30 pm
I have created a monster....

Seriously though, Thanks for the help. gets me a lot closer to the look and feel I wanted.


OK, I think we are ready for some lightning (do you hear evil laughter?)
Title: Re: Meander testing grounds
Post by: SMcNeill on September 17, 2020, 06:32:03 pm
This reminds me of the path and lighting generator which I was working on with my little rogue-clone, before life interrupted the start of a nice project.  You guys might want to take a look in it sometime.

https://www.qb64.org/forum/index.php?action=dlattach;topic=1696.0;attach=3795
Title: Re: Meander testing grounds
Post by: bplus on September 17, 2020, 07:15:59 pm
Hi Steve,

Yes, I remember that project start (don't remember the name) but arrowing around opened up tunnels and rooms. Your link is only downloading a screen shot.
Title: Re: Meander testing grounds
Post by: SMcNeill on September 17, 2020, 08:35:16 pm
Hi Steve,

Yes, I remember that project start (don't remember the name) but arrowing around opened up tunnels and rooms. Your link is only downloading a screen shot.

Sorry.  Copied the wrong link apparently.  Try this one: https://www.qb64.org/forum/index.php?topic=1696.msg109537#msg109537

CreateMap is the sub which draws our rooms and then meanders our paths for us.  My concept is really simple: Start at point A, and move towards point B, with a chance for the random variance which generates the “meandering”.


For example, say B is 10 steps due East from A...

Start at A:
East
East
North (random change)
North (again, the random change kicked in)
East
East
South (automatic course correction as we move towards B)
West (random kicked in again.)

And so on...

As long as your random variance is less than the chance for direct approach, you’ll eventually reach the goal.
Title: Re: Meander testing grounds
Post by: _vince on September 17, 2020, 09:26:49 pm
Fascinating! Nice work solving the 1105 rooms problem
Title: Re: Meander testing grounds
Post by: bplus on September 18, 2020, 11:05:32 pm
And here comes the lightning!

Watch out!

Code: QB64: [Select]
  1. _TITLE "Adding some lightning" ' b+ 2020-09-17   so much better in living color!!
  2. ' ah much better response on on escape or Q to quit! too.
  3.  
  4. SCREEN _NEWIMAGE(1024, 620, 32)
  5. _DELAY .25
  6. '_FULLSCREEN
  7. CONST flashy = &HFFFFFF88
  8. TYPE box
  9.     x AS SINGLE
  10.     y AS SINGLE
  11.     w AS SINGLE
  12.     h AS SINGLE
  13.     K AS _UNSIGNED LONG
  14.  
  15. TYPE move
  16.     x AS SINGLE
  17.     y AS SINGLE
  18.     'd AS INTEGER
  19.  
  20. DIM SHARED beeLineK AS _UNSIGNED LONG, gSize AS INTEGER
  21.  
  22.  
  23. DIM backColor AS _UNSIGNED LONG, hc AS INTEGER
  24.     'whole new set
  25.     REDIM VS(_WIDTH, _HEIGHT)
  26.     gSize = units(INT(40 * RND) + 11, 5)
  27.     nBoxes = INT(SQR(_WIDTH * _HEIGHT) / gSize * RND) + 1
  28.     IF nBoxes < 15 THEN nBoxes = 15
  29.     IF nBoxes > 100 THEN nBoxes = 100
  30.     COLOR &HFFFFFFFF, &HFF000000
  31.     PRINT gSize, nBoxes
  32.     '_DISPLAY
  33.     REDIM b(1 TO nBoxes) AS box 'new box set
  34.     FOR i = 1 TO nBoxes
  35.         tryAgain:
  36.         b(i).x = units(RND * (_WIDTH - 2 * (gSize + 1)) + gSize + 1, gSize) 'get x, y off the edges of screen!
  37.         b(i).y = units(RND * (_HEIGHT - 2 * (gSize + 1)) + gSize + 1, gSize)
  38.         IF i > 1 THEN
  39.             OK = -1
  40.             FOR j = 1 TO i - 1
  41.                 IF _HYPOT(b(j).x - b(i).x, b(j).y - b(i).y) < 3 * gSize THEN OK = 0: EXIT FOR
  42.             NEXT
  43.             IF OK = 0 THEN GOTO tryAgain
  44.         END IF
  45.         b(i).w = gSize + RND * gSize * .5
  46.         b(i).h = gSize + RND * gSize * .5
  47.         b(i).K = _RGB32(RND * 85 + 170, RND * 85 + 170, RND * 85 + 170)
  48.     NEXT
  49.     backColor = _RGB32(RND * 65, RND * 65, RND * 65)
  50.     hc = maxC(backColor)
  51.     IF hc = 1 THEN beeLineK = _RGB32(0, RND * 85 + 85, RND * 85 + 85)
  52.     IF hc = 2 THEN beeLineK = _RGB32(RND * 85 + 85, 0, RND * 85 + 85)
  53.     IF hc = 3 THEN beeLineK = _RGB32(RND * 85 + 85, RND * 85 + 85, 0)
  54.     COLOR , backColor
  55.     CLS
  56.     drawGrid gSize, gSize, _WIDTH - 1, _HEIGHT - 1, gSize, &HFF404040
  57.     'SLEEP
  58.     FOR i = 2 TO nBoxes '                                  draw the meanderings
  59.         meander2 b(i - 1).x, b(i - 1).y, b(i).x, b(i).y
  60.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  61.         LINE (b(i - 1).x - b(i - 1).w * .5, b(i - 1).y - b(i - 1).h * .5)-STEP(b(i - 1).w, b(i - 1).h), b(i - 1).K, BF 'draw the boxes
  62.     NEXT
  63.     FOR i = 1 TO nBoxes
  64.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  65.     NEXT
  66.  
  67.     '  and now for some lightning!!!
  68.     grd& = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
  69.     _PUTIMAGE , 0, grd&
  70.     DIM i AS LONG
  71.     i = 0
  72.     REDIM flash AS box, moves(0) AS move, mItem AS move
  73.     r = INT(RND * nBoxes) + 1 'pick a place to strike, light it up
  74.     moves(i).x = b(r).x: moves(i).y = b(r).y: flash.w = b(r).w: flash.h = b(r).h: flash.K = flashy
  75.     LINE (moves(i).x - .5 * flash.w, moves(i).y - .5 * flash.h)-STEP(flash.w, flash.h), flashy - RND * 150, BF
  76.     GOSUB checkoutThePlace
  77.     oldUB = 0
  78.     circuit:
  79.     ub = UBOUND(moves)
  80.     IF ub > oldUB THEN
  81.         _PUTIMAGE , grd&, 0
  82.         FOR i = oldUB TO ub
  83.             fcirc moves(i).x, moves(i).y, .33 * gSize, flashy - RND * 150
  84.             GOSUB checkoutThePlace
  85.         NEXT
  86.         oldUB = ub
  87.         _DISPLAY
  88.         _LIMIT 10
  89.         GOTO circuit
  90.     END IF
  91.     _PUTIMAGE , grd&, 0
  92.     BEEP
  93.     _FREEIMAGE grd&
  94.     SLEEP
  95.  
  96.  
  97. checkoutThePlace:
  98. IF moves(i).x + .5 * gSize >= 0 AND moves(i).x + .5 * gSize < _WIDTH THEN
  99.     IF VS(moves(i).x + .5 * gSize, moves(i).y) = 1 THEN
  100.         mItem.x = moves(i).x + gSize: mItem.y = moves(i).y
  101.         sAppend moves(), mItem
  102.         VS(moves(i).x + .5 * gSize, moves(i).y) = 0
  103.     END IF
  104. IF moves(i).y + .5 * gSize >= 0 AND moves(i).y + .5 * gSize < _HEIGHT THEN
  105.     IF VS(moves(i).x, moves(i).y + .5 * gSize) = 1 THEN
  106.         mItem.x = moves(i).x: mItem.y = moves(i).y + gSize
  107.         sAppend moves(), mItem
  108.         VS(moves(i).x, moves(i).y + .5 * gSize) = 0
  109.     END IF
  110. IF moves(i).x - .5 * gSize >= 0 AND moves(i).x - .5 * gSize < _WIDTH THEN
  111.     IF VS(moves(i).x - .5 * gSize, moves(i).y) = 1 THEN
  112.         mItem.x = moves(i).x - gSize: mItem.y = moves(i).y
  113.         sAppend moves(), mItem
  114.         VS(moves(i).x - .5 * gSize, moves(i).y) = 0
  115.     END IF
  116. IF moves(i).y - .5 * gSize >= 0 AND moves(i).y - .5 * gSize < _HEIGHT THEN
  117.     IF VS(moves(i).x, moves(i).y - .5 * gSize) = 1 THEN
  118.         mItem.x = moves(i).x: mItem.y = moves(i).y - gSize
  119.         sAppend moves(), mItem
  120.         VS(moves(i).x, moves(i).y - .5 * gSize) = 0
  121.     END IF
  122.  
  123. SUB meander2 (x1, y1, x2, y2) ' snap to grid!   gSize is shared
  124.     startx = x1: starty = y1: endx = x2: endy = y2
  125.     x = startx: y = starty
  126.     GOSUB dist
  127.     IF dist > 100 THEN
  128.         time = INT(RND * 8 + 4) ' total amount allowed to move  The More the time the more the meander!!!!
  129.     ELSE
  130.         time = 3
  131.     END IF
  132.     startTime = time '       > 20 is too much!!
  133.     IF RND < .5 THEN lastmoveX = 0 ELSE lastmoveX = -1
  134.     lastx = startx: lasty = starty
  135.     DO
  136.         GOSUB dist
  137.         IF RND < .5 THEN d = -1 ELSE d = 1
  138.         IF lastmoveX = 0 THEN
  139.             lastx = x
  140.             IF time <= 2 THEN
  141.                 x = endx
  142.             ELSE
  143.                 dx = units(d * (.4 * distx * RND + gSize), gSize)
  144.                 IF dx = 0 THEN dx = gSize
  145.                 IF x + dx > 0 AND x + dx < _WIDTH THEN
  146.                     x = x + dx
  147.                 ELSE
  148.                     x = x + -dx
  149.                 END IF
  150.             END IF
  151.             'LINE (lastx, y)-(x, y)
  152.             beeline lastx, y, x, y
  153.             lastmoveX = -1
  154.         ELSE
  155.             lasty = y
  156.             IF time <= 2 THEN
  157.                 y = endy
  158.             ELSE
  159.                 dy = units(d * (.3 * disty * RND + gSize), gSize)
  160.                 IF dy = 0 THEN dy = gSize
  161.                 IF y + dy > 0 AND y + dy < _HEIGHT THEN
  162.                     y = y + dy
  163.                 ELSE
  164.                     y = y + -dy
  165.                 END IF
  166.             END IF
  167.             'LINE (x, lasty)-(x, y)
  168.             beeline x, lasty, x, y
  169.             lastmoveX = 0
  170.         END IF
  171.         time = time - 1
  172.         '_LIMIT 10
  173.     LOOP UNTIL time <= 0
  174.     EXIT SUB
  175.     dist:
  176.     distx = endx - x: disty = endy - y
  177.     RETURN
  178.  
  179. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  180.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  181.     DIM X AS INTEGER, Y AS INTEGER
  182.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
  183.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  184.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  185.     WHILE X > Y
  186.         RadiusError = RadiusError + Y * 2 + 1
  187.         IF RadiusError >= 0 THEN
  188.             IF X <> Y + 1 THEN
  189.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  190.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  191.             END IF
  192.             X = X - 1
  193.             RadiusError = RadiusError - X * 2
  194.         END IF
  195.         Y = Y + 1
  196.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  197.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  198.     WEND
  199.  
  200. SUB beeline (x1, y1, x2, y2)
  201.     IF x1 = x2 THEN
  202.         IF y1 <= y2 THEN FOR y = y1 TO y2: fcirc x1, y, 2, beeLineK: VS(INT(x1), INT(y)) = 1: NEXT
  203.         IF y1 > y2 THEN FOR y = y1 TO y2 STEP -1: fcirc x1, y, 2, beeLineK: VS(INT(x1), INT(y)) = 1: NEXT
  204.     ELSE
  205.         IF x1 <= x2 THEN FOR x = x1 TO x2: fcirc x, y1, 2, beeLineK: VS(INT(x), INT(y1)) = 1: NEXT
  206.         IF x1 > x2 THEN FOR x = x1 TO x2 STEP -1: fcirc x, y1, 2, beeLineK: VS(INT(x), INT(y1)) = 1: NEXT
  207.     END IF
  208.  
  209.     IF _RED32(K) >= _GREEN32(K) AND _RED32(K) >= _BLUE32(K) THEN maxC = 1: EXIT FUNCTION
  210.     IF _GREEN32(K) >= _BLUE(K) THEN maxC = 2 ELSE maxC = 3
  211.  
  212. ' this sub needs FUNCTION units (x, unit)
  213. SUB drawGrid (x1, y1, x2, y2, gsize, gridClr AS _UNSIGNED LONG) ' grid of square gsize X gsize
  214.     ' fit a grid between x1, x2 and  y1, y2
  215.     ' x1, y1 top right corner and x2, y2 expected bottom right corner of boundary line
  216.  
  217.     DIM x AS INTEGER, y AS INTEGER, gx1 AS INTEGER, gy1 AS INTEGER, gx2 AS INTEGER, gy2 AS INTEGER
  218.     gx1 = units(x1, gsize): gy1 = units(y1, gsize) 'convert to grid coordinates
  219.     gx2 = units(x2, gsize): gy2 = units(y2, gsize)
  220.     IF gx1 < x1 THEN gx1 = gx1 + gsize 'stay inside boundarys passed to sub
  221.     IF gy1 < y1 THEN gy1 = gy1 + gsize
  222.     IF gx1 >= gx2 OR gy1 >= gy2 THEN EXIT SUB 'that's not even a single square!
  223.     FOR x = gx1 TO gx2 STEP gsize: LINE (x, gy1)-(x, gy2), gridClr: NEXT
  224.     FOR y = gy1 TO gy2 STEP gsize: LINE (gx1, y)-(gx2, y), gridClr: NEXT
  225.  
  226. FUNCTION units (x, unit)
  227.     units = INT(x / unit) * unit
  228.  
  229. SUB sAppend (arr() AS move, addItem AS move)
  230.     REDIM _PRESERVE arr(LBOUND(arr) TO UBOUND(arr) + 1) AS move
  231.     arr(UBOUND(arr)) = addItem
  232.  
  233.  
  234.  

EDIT: Oh ha! the lightning had some bugs. ;-))  fixed
Title: Re: Meander testing grounds
Post by: bplus on September 19, 2020, 12:45:16 am
Burn out the lights too: 
Code: QB64: [Select]
  1. _TITLE "Adding some lightning" ' b+ 2020-09-17   so much better in living color!!
  2. ' ah much better response on on escape or Q to quit! too.
  3.  
  4. SCREEN _NEWIMAGE(1024, 620, 32)
  5. _DELAY .25
  6. '_FULLSCREEN
  7. CONST flashy = &HFFFFFF00
  8. TYPE box
  9.     x AS SINGLE
  10.     y AS SINGLE
  11.     w AS SINGLE
  12.     h AS SINGLE
  13.     K AS _UNSIGNED LONG
  14.     hit AS INTEGER
  15.  
  16. TYPE move
  17.     x AS SINGLE
  18.     y AS SINGLE
  19.     'd AS INTEGER
  20.  
  21. DIM SHARED beeLineK AS _UNSIGNED LONG, gSize AS INTEGER
  22.  
  23.  
  24. DIM backColor AS _UNSIGNED LONG, hc AS INTEGER
  25.     'whole new set
  26.     REDIM VS(_WIDTH, _HEIGHT)
  27.     gSize = units(INT(20 * RND) + 6, 5)
  28.     nBoxes = INT(SQR(_WIDTH * _HEIGHT) / gSize * RND) + 1
  29.     IF nBoxes < 40 THEN nBoxes = 40
  30.     IF nBoxes > 100 THEN nBoxes = 100
  31.     COLOR &HFFFFFFFF, &HFF000000
  32.     PRINT gSize, nBoxes
  33.     '_DISPLAY
  34.     REDIM b(1 TO nBoxes) AS box 'new box set
  35.     FOR i = 1 TO nBoxes
  36.         tryAgain:
  37.         b(i).x = units(RND * (_WIDTH - 2 * (gSize + 1)) + gSize + 1, gSize) 'get x, y off the edges of screen!
  38.         b(i).y = units(RND * (_HEIGHT - 2 * (gSize + 1)) + gSize + 1, gSize)
  39.         IF i > 1 THEN
  40.             OK = -1
  41.             FOR j = 1 TO i - 1
  42.                 IF _HYPOT(b(j).x - b(i).x, b(j).y - b(i).y) < 3 * gSize THEN OK = 0: EXIT FOR
  43.             NEXT
  44.             IF OK = 0 THEN GOTO tryAgain
  45.         END IF
  46.         b(i).w = gSize + RND * gSize * .5
  47.         b(i).h = gSize + RND * gSize * .5
  48.         b(i).K = _RGB32(RND * 85 + 170, RND * 85 + 170, RND * 85 + 170)
  49.     NEXT
  50.     backColor = _RGB32(RND * 65, RND * 65, RND * 65)
  51.     hc = maxC(backColor)
  52.     IF hc = 1 THEN beeLineK = _RGB32(0, RND * 85 + 85, RND * 85 + 85)
  53.     IF hc = 2 THEN beeLineK = _RGB32(RND * 85 + 85, 0, RND * 85 + 85)
  54.     IF hc = 3 THEN beeLineK = _RGB32(RND * 85 + 85, RND * 85 + 85, 0)
  55.     COLOR , backColor
  56.     CLS
  57.     drawGrid gSize, gSize, _WIDTH - 1, _HEIGHT - 1, gSize, &HFF404040
  58.     'SLEEP
  59.     FOR i = 2 TO nBoxes '                                  draw the meanderings
  60.         meander2 b(i - 1).x, b(i - 1).y, b(i).x, b(i).y
  61.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  62.         LINE (b(i - 1).x - b(i - 1).w * .5, b(i - 1).y - b(i - 1).h * .5)-STEP(b(i - 1).w, b(i - 1).h), b(i - 1).K, BF 'draw the boxes
  63.     NEXT
  64.     FOR i = 1 TO nBoxes
  65.         LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), b(i).K, BF 'draw the boxes
  66.     NEXT
  67.  
  68.     '  and now for some lightning!!!
  69.     grd& = _NEWIMAGE(_WIDTH, _HEIGHT, 32)
  70.     _PUTIMAGE , 0, grd&
  71.     DIM i AS LONG
  72.     i = 0
  73.     REDIM flash AS box, moves(0) AS move, mItem AS move
  74.     r = INT(RND * nBoxes) + 1 'pick a place to strike, light it up
  75.     moves(i).x = b(r).x: moves(i).y = b(r).y: flash.w = b(r).w: flash.h = b(r).h: flash.K = flashy
  76.     LINE (moves(i).x - .5 * flash.w, moves(i).y - .5 * flash.h)-STEP(flash.w, flash.h), flashy, BF
  77.     GOSUB checkoutThePlace
  78.     oldUB = 0
  79.     circuit:
  80.     ub = UBOUND(moves)
  81.     IF ub > oldUB THEN
  82.         _PUTIMAGE , grd&, 0
  83.         FOR i = 1 TO nBoxes
  84.             IF b(i).hit THEN LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), &HFF551100, BF
  85.         NEXT
  86.         FOR i = oldUB TO ub
  87.             fcirc moves(i).x, moves(i).y, .33 * gSize, flashy - RND * 150
  88.             FOR j = 1 TO nBoxes
  89.                 IF moves(i).x = b(j).x AND moves(i).y = b(j).y THEN b(j).hit = 1
  90.             NEXT
  91.             GOSUB checkoutThePlace
  92.         NEXT
  93.         oldUB = ub
  94.         _DISPLAY
  95.         _LIMIT 10
  96.         GOTO circuit
  97.     END IF
  98.     _PUTIMAGE , grd&, 0
  99.     FOR i = 1 TO nBoxes
  100.         IF b(i).hit THEN LINE (b(i).x - b(i).w * .5, b(i).y - b(i).h * .5)-STEP(b(i).w, b(i).h), &HFF551100, BF
  101.     NEXT
  102.     BEEP
  103.     _FREEIMAGE grd&
  104.     SLEEP
  105.  
  106.  
  107. checkoutThePlace:
  108. IF moves(i).x + .5 * gSize >= 0 AND moves(i).x + .5 * gSize < _WIDTH THEN
  109.     IF VS(moves(i).x + .5 * gSize, moves(i).y) = 1 THEN
  110.         mItem.x = moves(i).x + gSize: mItem.y = moves(i).y
  111.         sAppend moves(), mItem
  112.         VS(moves(i).x + .5 * gSize, moves(i).y) = 0
  113.     END IF
  114. IF moves(i).y + .5 * gSize >= 0 AND moves(i).y + .5 * gSize < _HEIGHT THEN
  115.     IF VS(moves(i).x, moves(i).y + .5 * gSize) = 1 THEN
  116.         mItem.x = moves(i).x: mItem.y = moves(i).y + gSize
  117.         sAppend moves(), mItem
  118.         VS(moves(i).x, moves(i).y + .5 * gSize) = 0
  119.     END IF
  120. IF moves(i).x - .5 * gSize >= 0 AND moves(i).x - .5 * gSize < _WIDTH THEN
  121.     IF VS(moves(i).x - .5 * gSize, moves(i).y) = 1 THEN
  122.         mItem.x = moves(i).x - gSize: mItem.y = moves(i).y
  123.         sAppend moves(), mItem
  124.         VS(moves(i).x - .5 * gSize, moves(i).y) = 0
  125.     END IF
  126. IF moves(i).y - .5 * gSize >= 0 AND moves(i).y - .5 * gSize < _HEIGHT THEN
  127.     IF VS(moves(i).x, moves(i).y - .5 * gSize) = 1 THEN
  128.         mItem.x = moves(i).x: mItem.y = moves(i).y - gSize
  129.         sAppend moves(), mItem
  130.         VS(moves(i).x, moves(i).y - .5 * gSize) = 0
  131.     END IF
  132.  
  133. SUB meander2 (x1, y1, x2, y2) ' snap to grid!   gSize is shared
  134.     startx = x1: starty = y1: endx = x2: endy = y2
  135.     x = startx: y = starty
  136.     GOSUB dist
  137.     IF dist > 100 THEN
  138.         time = INT(RND * 8 + 4) ' total amount allowed to move  The More the time the more the meander!!!!
  139.     ELSE
  140.         time = 3
  141.     END IF
  142.     startTime = time '       > 20 is too much!!
  143.     IF RND < .5 THEN lastmoveX = 0 ELSE lastmoveX = -1
  144.     lastx = startx: lasty = starty
  145.     DO
  146.         GOSUB dist
  147.         IF RND < .5 THEN d = -1 ELSE d = 1
  148.         IF lastmoveX = 0 THEN
  149.             lastx = x
  150.             IF time <= 2 THEN
  151.                 x = endx
  152.             ELSE
  153.                 dx = units(d * (.4 * distx * RND + gSize), gSize)
  154.                 IF dx = 0 THEN dx = gSize
  155.                 IF x + dx > 0 AND x + dx < _WIDTH THEN
  156.                     x = x + dx
  157.                 ELSE
  158.                     x = x + -dx
  159.                 END IF
  160.             END IF
  161.             'LINE (lastx, y)-(x, y)
  162.             beeline lastx, y, x, y
  163.             lastmoveX = -1
  164.         ELSE
  165.             lasty = y
  166.             IF time <= 2 THEN
  167.                 y = endy
  168.             ELSE
  169.                 dy = units(d * (.3 * disty * RND + gSize), gSize)
  170.                 IF dy = 0 THEN dy = gSize
  171.                 IF y + dy > 0 AND y + dy < _HEIGHT THEN
  172.                     y = y + dy
  173.                 ELSE
  174.                     y = y + -dy
  175.                 END IF
  176.             END IF
  177.             'LINE (x, lasty)-(x, y)
  178.             beeline x, lasty, x, y
  179.             lastmoveX = 0
  180.         END IF
  181.         time = time - 1
  182.         '_LIMIT 10
  183.     LOOP UNTIL time <= 0
  184.     EXIT SUB
  185.     dist:
  186.     distx = endx - x: disty = endy - y
  187.     RETURN
  188.  
  189. SUB fcirc (CX AS INTEGER, CY AS INTEGER, R AS INTEGER, C AS _UNSIGNED LONG)
  190.     DIM Radius AS INTEGER, RadiusError AS INTEGER
  191.     DIM X AS INTEGER, Y AS INTEGER
  192.     Radius = ABS(R): RadiusError = -Radius: X = Radius: Y = 0
  193.     IF Radius = 0 THEN PSET (CX, CY), C: EXIT SUB
  194.     LINE (CX - X, CY)-(CX + X, CY), C, BF
  195.     WHILE X > Y
  196.         RadiusError = RadiusError + Y * 2 + 1
  197.         IF RadiusError >= 0 THEN
  198.             IF X <> Y + 1 THEN
  199.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  200.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  201.             END IF
  202.             X = X - 1
  203.             RadiusError = RadiusError - X * 2
  204.         END IF
  205.         Y = Y + 1
  206.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  207.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  208.     WEND
  209.  
  210. SUB beeline (x1, y1, x2, y2)
  211.     IF x1 = x2 THEN
  212.         IF y1 <= y2 THEN FOR y = y1 TO y2: fcirc x1, y, 1, beeLineK: VS(INT(x1), INT(y)) = 1: NEXT
  213.         IF y1 > y2 THEN FOR y = y1 TO y2 STEP -1: fcirc x1, y, 1, beeLineK: VS(INT(x1), INT(y)) = 1: NEXT
  214.     ELSE
  215.         IF x1 <= x2 THEN FOR x = x1 TO x2: fcirc x, y1, 1, beeLineK: VS(INT(x), INT(y1)) = 1: NEXT
  216.         IF x1 > x2 THEN FOR x = x1 TO x2 STEP -1: fcirc x, y1, 1, beeLineK: VS(INT(x), INT(y1)) = 1: NEXT
  217.     END IF
  218.  
  219.     IF _RED32(K) >= _GREEN32(K) AND _RED32(K) >= _BLUE32(K) THEN maxC = 1: EXIT FUNCTION
  220.     IF _GREEN32(K) >= _BLUE(K) THEN maxC = 2 ELSE maxC = 3
  221.  
  222. ' this sub needs FUNCTION units (x, unit)
  223. SUB drawGrid (x1, y1, x2, y2, gsize, gridClr AS _UNSIGNED LONG) ' grid of square gsize X gsize
  224.     ' fit a grid between x1, x2 and  y1, y2
  225.     ' x1, y1 top right corner and x2, y2 expected bottom right corner of boundary line
  226.  
  227.     DIM x AS INTEGER, y AS INTEGER, gx1 AS INTEGER, gy1 AS INTEGER, gx2 AS INTEGER, gy2 AS INTEGER
  228.     gx1 = units(x1, gsize): gy1 = units(y1, gsize) 'convert to grid coordinates
  229.     gx2 = units(x2, gsize): gy2 = units(y2, gsize)
  230.     IF gx1 < x1 THEN gx1 = gx1 + gsize 'stay inside boundarys passed to sub
  231.     IF gy1 < y1 THEN gy1 = gy1 + gsize
  232.     IF gx1 >= gx2 OR gy1 >= gy2 THEN EXIT SUB 'that's not even a single square!
  233.     FOR x = gx1 TO gx2 STEP gsize: LINE (x, gy1)-(x, gy2), gridClr: NEXT
  234.     FOR y = gy1 TO gy2 STEP gsize: LINE (gx1, y)-(gx2, y), gridClr: NEXT
  235.  
  236. FUNCTION units (x, unit)
  237.     units = INT(x / unit) * unit
  238.  
  239. SUB sAppend (arr() AS move, addItem AS move)
  240.     REDIM _PRESERVE arr(LBOUND(arr) TO UBOUND(arr) + 1) AS move
  241.     arr(UBOUND(arr)) = addItem
  242.  
  243.  

BTW the beep is to remind you to hit the spacebar.