 August 14, 2020, 11:43:40 PM

### Author Topic: Fun with hexagons  (Read 1510 times)

#### chrisws

• Jr. Member
•  • Posts: 55 ##### Fun with hexagons
« on: February 03, 2020, 09:18:07 PM »
Code: [Select]
`remrem https://www.redblobgames.com/grids/hexagons/rem sub draw_grid(size, pointy, col)  local v1 = sqr(3) * size  local v2 = size * 2  local border = 3  local width = iff(pointy, v1, v2)  local height = iff(pointy, v2, v1)  local x_start, row    func flat_hex_corner(x, y, i)    local angle = rad(iff(pointy, 30,0) + 60 * i)    return [x + (size - border) * cos(angle), y + (size - border) * sin(angle)]  end    func hexagon(x, y)    local i, a    for i = 0 to 6      a << flat_hex_corner(x, y, i)    next i    return a  end    row = 0  for y = height to ymax step height    x_start = iff(row %2 == 0, width, width / 2)    for x = x_start to xmax - width step width      drawpoly hexagon(x, y) color col filled    next x    row++  next yendzr=1i=5while 1  i+=zr  if (i>110) then zr=-1  if (i=5) then zr=1  j= !j  draw_grid(i+2,j,2)  draw_grid(i+3,j,3)  draw_grid(i+4,j,4)  draw_grid(i+5,j,1)  showpage  delay max(1, 100-i)  clswend`

#### bplus ##### Re: Fun with hexagons
« Reply #1 on: February 04, 2020, 03:18:42 PM »
Thanks Chris

I pick up tips studying your code. Functions inside a Sub? Does it matter? And returning points and arrays, don't see that with QB64 nor drawpoly with or without filled option. #### bplus ##### Re: Fun with hexagons
« Reply #2 on: February 05, 2020, 04:11:09 PM »
Hi Chris,

I am trying to translate a Hexagon Minesweeper Game from QB64 and it seems that PAINT to a border is flooding screen whereas PAINT without border will fill hexagon OK, is there a known bug with using the border color option? I think I tried both RGB and regular QB colors for border color.

Also, I look up PEN() from Help and there is nothing about crucial Mouse polling ie what are the Pen options available? Also PEN ON/OFF the only help given is no longer necessary as I recall? Really needs better documentation. SmallBASIC forum says well here is the shot

and the not so helpful one from github

#### bplus ##### Re: Fun with hexagons
« Reply #3 on: February 06, 2020, 03:33:53 PM »
More fun (when sweepZero's doesn't blow the stack!)

Hexagonal Minesweeper:
Code: [Select]
`'Hexagon Minesweeper.bas for SmallBASIC dev 12.13 bplus 2020-02-04 translated from'Hexagon Minesweeper.bas for QB64 by Bplus 2019-08-07 instigated by Steve McNeill' 2019-08-08 fixed incomplete sweepZeros problem' 2020-02-05 SmallBASIC v 12.13 (v 12.17 bugged out permanently loosing letter keys!!!!) '  blows stack now and then sweeping Zero's even with this puny 10 x 10 field ;(RANDOMIZE TIMERCONST cellR = 25const arrDx = 10  '10 works but puny board higher numbers overcome stack const arrDy = 10const mines = int(arrDx * arrDy * .14)xspacing = 2 * cellR * COS(rad(30))yspacing = cellR * (1 + SIN(rad(30)))dim b(arrDx + 1, arrDy + 1) 'boarddim dxdyOFF(6, 1), dxdyNoOff(6, 1) 'set direction according to six sides and offset hexagon or not'set the 2 sets of directions to neighbors a cell could have depending if the row is offset or notRESTORE NoOffFOR i = 0 TO 5    READ dx, dy    dxdyNoOff(i, 0) = dx: dxdyNoOff(i, 1) = dyNEXTRESTORE xOffFOR i = 0 TO 5    READ dx, dy    dxdyOFF(i, 0) = dx: dxdyOFF(i, 1) = dyNEXTrestart = 1WHILE 1    gameOver = 0    WHILE gameOver = 0        IF restart THEN initialize        okay = 0        getCell cc, cr, okay        IF redOn = 0 AND b(cc, cr).reveal = 0 and okay THEN            IF b(cc, cr).mine THEN 'ka boom                FOR r = 1 TO arrDy 'show all mines                    FOR c = 1 TO arrDy                        IF b(c, r).mine THEN b(c, r).reveal = -1: showCell c, r                    NEXT                NEXT                Text xmax / 2, ymax - 72, 72, 14, 0,  "KA - BOOOMMMM!"                gameOver = -1                delay 4000            ELSE                b(cc, cr).reveal = -1: showCell cc, cr                IF b(cc, cr).id = 0 THEN sweepZeros cc, cr            END IF        ELSEIF redOn and Okay            IF b(cc, cr).reveal = 1 THEN                b(cc, cr).reveal = 0: showCell cc, cr            ELSE                IF b(cc, cr).reveal = 0 THEN b(cc, cr).reveal = 1: showCell cc, cr            END IF            delay 30        END IF        IF TFwin THEN            Text xmax / 2 - 1, ymax - 72, 72, 9, 15, "Good Job!"            delay 3000            gameOver = -1        END IF        delay 30    WEND    restart = 1    clsWENDlabel NoOff:DATA 1,0,0,-1,0,1,-1,-1,-1,0,-1,1label xOff:DATA -1,0,0,-1,0,1,1,-1,1,0,1,1SUB initialize ()  local minesplaced, rx, ry, x, y, nMines, offset  CLS  restart = 0 : redON = 0  DIM b(arrDx + 1, arrDy + 1) 'AS boardType  minesPlaced = 0  WHILE minesPlaced < mines    rx = INT(RND * arrDx) + 1: ry = INT(RND * arrDy) + 1    IF b(rx, ry).mine = 0 THEN      b(rx, ry).mine = -1: minesPlaced = minesPlaced + 1    END IF  WEND  'count mines amoung the neighbors  FOR y = 1 TO arrDy    IF y MOD 2 = 0 THEN xoffset = .5 * xspacing ELSE xoffset = 0    FOR x = 1 TO arrDx      IF b(x, y).mine <> -1 THEN 'not already a mine        '2 sets of neighbors depending if x offset or not        IF xoffset > .1 THEN          nMines = b(x - 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine          nMines = nMines + b(x + 1, y - 1).mine + b(x + 1, y).mine + b(x + 1, y + 1).mine        ELSE          nMines = b(x + 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine          nMines = nMines + b(x - 1, y - 1).mine + b(x - 1, y).mine + b(x - 1, y + 1).mine        END IF        b(x, y).id = -nMines      ELSE        b(x, y).id = 0      END IF      b(x, y).x = x * xspacing + xoffset + 5      b(x, y).y = y * yspacing + 5      b(x, y).reveal = 0      showCell x, y    NEXT  NEXT  text xmax/2, ymax - 148, 20, 15, 12, " Press Spacebar to toggle Red Mine Marker (ON = Red at Right) " END SUBSUB showCell (c, r)  local da, x, y, lastx, lasty, clr  SELECT CASE b(c, r).reveal  CASE -1: IF b(c, r).mine THEN clr = 12 ELSE clr = 15 'revealed  white with number of mine neighbors  CASE 0: clr = 2 ' hidden green  CASE 1: clr = 12 ' marked red  END SELECT  lastx = b(c, r).x + cellR * COS(rad(-30))  lasty = b(c, r).y + cellR * SIN(rad(-30))  FOR da = 30 TO 330 STEP 60    x = b(c, r).x + cellR * COS(rad(da))    y = b(c, r).y + cellR * SIN(rad(da))    LINE lastx, lasty, x, y, 13    lastx = x: lasty = y  NEXT  PAINT b(c, r).x, b(c, r).y, clr  IF b(c, r).reveal = -1 THEN    IF b(c, r).id > 0 THEN text b(c, r).x, b(c, r).y + 1, 20, 0, 15, str(b(c, r).id)    IF b(c, r).mine = -1 THEN text b(c, r).x, b(c, r).y + 4, 20, 15, 12, "*"  ENDIFEND SUBFUNC TFwin  'count cleared cells  local c, x, y  FOR y = 1 TO arrDy    FOR x = 1 TO arrDx      IF b(x, y).reveal = -1 AND b(x, y).mine = 0 THEN c = c + 1    NEXT  NEXT  IF c = arrDx * arrDy - mines THEN TFwin = -1ENDSUB getCell (byref returnCol, byref returnRow, byref OK)  local m, mx, my, mb, r, c, k   ' pen  mb = pen(3)   if inkey = " " then redOn = !redON  if redON then k = 12 else k = 0  rect xmax - 100, 0, xmax, ymax, k filled   IF mb then    mx = pen(4) : my = pen(5)    FOR r = 1 TO arrDy      FOR c = 1 TO arrDx        IF ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xspacing THEN          returnCol = c: returnRow = r: OK = 1 : EXIT SUB        END IF      NEXT    NEXT    while mb : mb = pen(3): delay 15 : wend  'one mouse click at a time please  END IF  OK = 0END SUBSUB sweepZeros (col, row)   'something is tripping up the sweep specially when lots of reveals  'tried a separate Text2 for less calls to changing font size (mostly back to same size as was), nope no fix  'now trying NO CALLs to showCell and displaying whole board again each loop through main, nope no fix  local c, r, d, x, y  c = col: r = row 'get copies for recursive sub  FOR d = 0 TO 5    IF r MOD 2 = 0 THEN      x = dxdyOFF(d, 0) + c: y = dxdyOFF(d, 1) + r    ELSE      x = dxdyNoOff(d, 0) + c: y = dxdyNoOff(d, 1) + r    END IF    IF (x >= 1 AND x <= arrDx) AND (y >= 1 AND y <= arrDy) THEN      IF b(x, y).reveal = 0 and b(x, y).mine = 0 THEN        b(x, y).reveal = -1 'mark played        showCell x, y         if b(x, y).id = 0 then sweepZeros x, y      END IF    END IF  NEXTEND SUBsub Text(x, y, size, fcolor, bcolor, s)  local l  l.w = window() : l.w.setfont(size, "pt", 0, 0)  color fcolor, bcolor  at x - .5 * textwidth(s), y - .5 * textHeight(s) : ? s;  color 15, 0  l.w = window() : l.w.setfont(20, "pt", 0, 0)end`

#### chrisws

• Jr. Member
•  • Posts: 55 ##### Re: Fun with hexagons
« Reply #4 on: February 07, 2020, 10:25:28 AM »
Looks amazing. But you know what would be even more awesome... your particle explosion code instead of Kaboom!

I will try and fix up the PEN docs soon. I'm not sure if there's a bug in PAINT, I will have a play and see.

I'm making a minor update to fix my stupid keyboard handling issue (I see you've left some notes in the other thread).

#### bplus ##### Re: Fun with hexagons
« Reply #5 on: February 07, 2020, 04:55:13 PM »
Hi Chris,

Well you are consistent, you had same comment a couple of years ago for regular Minesweeper.

I don't know how much time you have to play around with things but increase arrDx say to 20 or even 15 and the thing errors out easy. Since it loads pages with "error", I assume it is a stack problem which is odd because regular Minesweeper could handle much larger game boards...

By popular demand (twice now from highly respected coder), I will look into exploding game boards. #### bplus ##### Re: Fun with hexagons
« Reply #6 on: February 08, 2020, 03:02:01 AM »
Fixed problem with stack by dumping recursive sub and used a "stack" array instead, plus some other improvements...
Now the Mine Field Fills the screen:
Code: [Select]
`'hexagon minesweeper.bas for smallbasic dev 12.13 bplus 2020-02-04 translated from'hexagon minesweeper.bas for qb64 by bplus 2019-08-07 instigated by steve mcneill' 2020-02-07 fix stack problem with recursive sub by dumping it and using a stack array instead.' Now I can expand the field to fill the screen! Added an r keypress option to restart a game.randomize timerconst cellr = 25const arrdx = 26  '10 works but puny board higher numbers overcome stack const arrdy = 14const mines = int(arrdx * arrdy * .14)const dm30 = -1/6 * piconst d30 = 1/6 * piconst d60 = 1/3 * piconst d330 = 2 * pi + dm30xspacing = 2 * cellr * cos(d30)yspacing = cellr * (1 + sin(d30))dim b(arrdx + 1, arrdy + 1) 'boarddim dxdyOff(6, 1), dxdyNoOff(6, 1) 'set direction according to six sides and offset hexagon or not'set the 2 sets of directions to neighbors a cell could have depending if the row is offset or notrestore noOfffor i = 0 to 5    read dx, dy    dxdyNoOff(i, 0) = dx: dxdyNoOff(i, 1) = dynextrestore xofffor i = 0 to 5    read dx, dy    dxdyOff(i, 0) = dx: dxdyOff(i, 1) = dynextrestart = 1while 1    gameover = 0    while gameover = 0        if restart then initialize        okay = 0        getcell cc, cr, okay        if redon = 0 and b(cc, cr).reveal = 0 and okay then            if b(cc, cr).mine then 'ka boom                for r = 1 to arrdy 'show all mines                    for c = 1 to arrdx                         if b(c, r).mine then b(c, r).reveal = -1: showcell c, r                    next                next                text xmax / 2, ymax - 72, 72, 14, 0,  "ka - booommmm!"                gameover = -1                delay 4000            else                b(cc, cr).reveal = -1: showcell cc, cr                if b(cc, cr).id = 0 then sweep0 cc, cr            end if        elseif redon and okay            if b(cc, cr).reveal = 1 then                b(cc, cr).reveal = 0: showcell cc, cr            else                if b(cc, cr).reveal = 0 then b(cc, cr).reveal = 1: showcell cc, cr            end if        end if        if tfwin then            text xmax / 2 - 1, ymax - 72, 72, 9, 15, "good job!"            delay 4000            gameover = -1        end if    wend    restart = 1    clswendlabel noOff:data 1,0,0,-1,0,1,-1,-1,-1,0,-1,1label xoff:data -1,0,0,-1,0,1,1,-1,1,0,1,1sub initialize ()  local minesplaced, rx, ry, x, y, nmines, offset  cls  text xmax/2, ymax - 148, 20, 15, 12, " press spacebar to toggle red mine marker (on = red at right) "  restart = 0 : redon = 0  dim b(arrdx + 1, arrdy + 1) 'as boardtype  minesplaced = 0  while minesplaced < mines    rx = int(rnd * arrdx) + 1: ry = int(rnd * arrdy) + 1    if b(rx, ry).mine = 0 then      b(rx, ry).mine = -1: minesplaced = minesplaced + 1    end if  wend    'count mines amoung the neighbors  for y = 1 to arrdy    if y mod 2 = 0 then xoffset = .5 * xspacing else xoffset = 0    for x = 1 to arrdx      if b(x, y).mine <> -1 then 'not already a mine        '2 sets of neighbors depending if x offset or not        if xoffset > .1 then          nmines = b(x - 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine          nmines = nmines + b(x + 1, y - 1).mine + b(x + 1, y).mine + b(x + 1, y + 1).mine        else          nmines = b(x + 1, y).mine + b(x, y - 1).mine + b(x, y + 1).mine          nmines = nmines + b(x - 1, y - 1).mine + b(x - 1, y).mine + b(x - 1, y + 1).mine        end if        b(x, y).id = -nmines      else        b(x, y).id = 0      end if      b(x, y).x = x * xspacing + xoffset + 5      b(x, y).y = y * yspacing + 5      b(x, y).reveal = 0      showcell x, y    next  nextend subsub showcell (c, r)  local da, arr  select case b(c, r).reveal  case -1: if b(c, r).mine then color 12, 0 else color 15, 0  'revealed white with number of mine neighbors  case 0: color  2, 0 ' hidden green  case 1: color 12, 0' marked red  end select  for da = dm30 to d330 step d60    arr << b(c, r).x + cellr * cos(da)    arr << b(c, r).y + cellr * sin(da)  next  drawpoly arr filled  color 13, 0  drawpoly arr  if b(c, r).reveal = -1 then    if b(c, r).id > 0 then text b(c, r).x, b(c, r).y + 1, 20, 0, 15, str(b(c, r).id)    if b(c, r).mine = -1 then text b(c, r).x, b(c, r).y + 4, 20, 15, 12, "*"  endif  color 15, 0end sub  func tfwin  'count cleared cells  local c, x, y  for y = 1 to arrdy    for x = 1 to arrdx      if b(x, y).reveal = -1 and b(x, y).mine = 0 then c = c + 1    next  next  if c = arrdx * arrdy - mines then tfwin = -1endsub getcell (byref returncol, byref returnrow, byref ok)  local m, mx, my, mb, r, c, k   ' pen  mb = pen(3)   k = inkey  if k = "r" then gameover = -1 '<<< faster debug testing  if k = " " then redon = !redon  if redon then k = 12 else k = 0  rect xmax - 100, 0, xmax, ymax, k filled   if mb then    mx = pen(4) : my = pen(5)    while mb : mb = pen(3): delay 60 : wend  'one mouse click at a time please    for r = 1 to arrdy      for c = 1 to arrdx        if ((mx - b(c, r).x) ^ 2 + (my - b(c, r).y) ^ 2) ^ .5 < .5 * xspacing then          returncol = c: returnrow = r: ok = 1 : exit sub        end if      next    next  end if  ok = 0end subsub text(x, y, size, fcolor, bcolor, s)  local l  l.w = window() : l.w.setfont(size, "pt", 0, 0)  color fcolor, bcolor  at x - .5 * textwidth(s), y - .5 * textheight(s) : ? s;  color 15, 0  l.w = window() : l.w.setfont(20, "pt", 0, 0)endsub sweep0 (col, row) 'non recursive  local d, x, y, stack, sti  dim stack()  label again:  for d = 0 to 5    if row mod 2 = 0 then      x = dxdyoff(d, 0) + col: y = dxdyoff(d, 1) + row    else      x = dxdynooff(d, 0) + col: y = dxdynooff(d, 1) + row    end if    if (x >= 1 and x <= arrdx) and (y >= 1 and y <= arrdy) then      if b(x, y).reveal = 0 and b(x, y).mine = 0 then        b(x, y).reveal = -1 'mark played        showcell x, y         if b(x, y).id = 0 then           append stack, x, y        end if      end if    end if  next  if ubound(stack)    row = stack(ubound(stack))    delete stack, ubound(stack)    col = stack(ubound(stack))    delete stack, ubound(stack)    goto again  end if end sub`

#### bplus ##### Re: Fun with hexagons
« Reply #7 on: February 08, 2020, 11:58:02 PM »
Here is some more modifications for Minesweeper with explosion of board and sound effect. Man I only found one wav file that would work in SmallBASIC, fortunately it was the most important one. I have also adjusted the mine field to fill your screen with cells based on your systems xmax, ymax settings.

Update: See next reply for two explosion versions in attached file.

#### bplus ##### Re: Fun with hexagons
« Reply #8 on: February 09, 2020, 04:23:32 AM »
OK that was one way to do explosions, here is another, better way, except in SmallBASIC it is sort of in slow motion. Remember when the 6 Million Dollar man use to run? The attached .zip contains the SmallBASIC source code for 2 explosion methods plus .wav

#### bplus ##### Re: Fun with hexagons
« Reply #9 on: February 09, 2020, 06:42:21 PM »
I liked this so much I took it back to QB64 and really blow up the board!
https://www.syntaxbomb.com/index.php/topic,7079.msg34156.html#msg34156

#### chrisws

• Jr. Member
•  • Posts: 55 ##### Re: Fun with hexagons
« Reply #10 on: February 14, 2020, 10:04:17 PM »
I liked this so much I took it back to QB64 and really blow up the board!
https://www.syntaxbomb.com/index.php/topic,7079.msg34156.html#msg34156
Nice, I still think it would be good if there was a way to make the same code work in both environments, something like this:

Code: [Select]
`#!QB64... QB64 syntax#!SB... SmallBASIC syntax#... interoperable code that already works in both systems`

#### bplus ##### Re: Fun with hexagons
« Reply #11 on: February 15, 2020, 05:30:34 PM »
I liked this so much I took it back to QB64 and really blow up the board!
https://www.syntaxbomb.com/index.php/topic,7079.msg34156.html#msg34156
Nice, I still think it would be good if there was a way to make the same code work in both environments, something like this:

Code: [Select]
`#!QB64... QB64 syntax#!SB... SmallBASIC syntax#... interoperable code that already works in both systems`

Well they both branch from same tree QB45 or so but QB64 is developed and compiled in C+ with Open GL for graphics package and SmallBASIC going down another path...

Qb64 sure could use SmallBASIC's array tools! and would be nice not to have to worry about TYPE's.

#### round157

• Sr. Member
•    • Posts: 366 ##### Re: Fun with hexagons
« Reply #12 on: February 19, 2020, 04:31:51 PM »

Well they both branch from same tree QB45 or so but QB64 is developed and compiled in C+ with Open GL for graphics package and SmallBASIC going down another path...

Hi, I have a question. What is SmallBASIC's another path?

#### bplus ##### Re: Fun with hexagons
« Reply #13 on: February 20, 2020, 06:39:16 AM »
SmallBASIC is developed in C and graphics package is either SDL or FLTK with the one original developer still active after all these years, whereas a trio or more have picked up the ball with QB64 and continue to carry it forward into the future.

Both can still run original QB code, can VB do that? would we want it to? ;-))

#### round157

• Sr. Member
•    • Posts: 366 ##### Re: Fun with hexagons
« Reply #14 on: February 21, 2020, 08:45:00 AM »
SmallBASIC is developed in C and graphics package is either SDL or FLTK